home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / expr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  64.5 KB  |  3,367 lines
  1. /****************************************************************
  2. Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "output.h"
  26. #include "names.h"
  27.  
  28. typedef struct { double dreal, dimag; } dcomplex;
  29.  
  30. static void consbinop Argdcl((int, int, Constp, Constp, Constp));
  31. static void conspower Argdcl((Constp, Constp, long int));
  32. static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*));
  33. static tagptr mkpower Argdcl((tagptr));
  34. static tagptr stfcall Argdcl((Namep, struct Listblock*));
  35.  
  36. extern char dflttype[26];
  37. extern int htype;
  38.  
  39. /* little routines to create constant blocks */
  40.  
  41.  Constp
  42. #ifdef KR_headers
  43. mkconst(t)
  44.     register int t;
  45. #else
  46. mkconst(register int t)
  47. #endif
  48. {
  49.     register Constp p;
  50.  
  51.     p = ALLOC(Constblock);
  52.     p->tag = TCONST;
  53.     p->vtype = t;
  54.     return(p);
  55. }
  56.  
  57.  
  58. /* mklogcon -- Make Logical Constant */
  59.  
  60.  expptr
  61. #ifdef KR_headers
  62. mklogcon(l)
  63.     register int l;
  64. #else
  65. mklogcon(register int l)
  66. #endif
  67. {
  68.     register Constp  p;
  69.  
  70.     p = mkconst(tylog);
  71.     p->Const.ci = l;
  72.     return( (expptr) p );
  73. }
  74.  
  75.  
  76.  
  77. /* mkintcon -- Make Integer Constant */
  78.  
  79.  expptr
  80. #ifdef KR_headers
  81. mkintcon(l)
  82.     ftnint l;
  83. #else
  84. mkintcon(ftnint l)
  85. #endif
  86. {
  87.     register Constp p;
  88.  
  89.     p = mkconst(tyint);
  90.     p->Const.ci = l;
  91.     return( (expptr) p );
  92. }
  93.  
  94.  
  95.  
  96.  
  97. /* mkaddcon -- Make Address Constant, given integer value */
  98.  
  99.  expptr
  100. #ifdef KR_headers
  101. mkaddcon(l)
  102.     register long l;
  103. #else
  104. mkaddcon(register long l)
  105. #endif
  106. {
  107.     register Constp p;
  108.  
  109.     p = mkconst(TYADDR);
  110.     p->Const.ci = l;
  111.     return( (expptr) p );
  112. }
  113.  
  114.  
  115.  
  116. /* mkrealcon -- Make Real Constant.  The type t is assumed
  117.    to be TYREAL or TYDREAL */
  118.  
  119.  expptr
  120. #ifdef KR_headers
  121. mkrealcon(t, d)
  122.     register int t;
  123.     char *d;
  124. #else
  125. mkrealcon(register int t, char *d)
  126. #endif
  127. {
  128.     register Constp p;
  129.  
  130.     p = mkconst(t);
  131.     p->Const.cds[0] = cds(d,CNULL);
  132.     p->vstg = 1;
  133.     return( (expptr) p );
  134. }
  135.  
  136.  
  137. /* mkbitcon -- Make bit constant.  Reads the input string, which is
  138.    assumed to correctly specify a number in base 2^shift (where   shift
  139.    is the input parameter).   shift   may not exceed 4, i.e. only binary,
  140.    quad, octal and hex bases may be input.  Constants may not exceed 32
  141.    bits, or whatever the size of (struct Constblock).ci may be. */
  142.  
  143.  expptr
  144. #ifdef KR_headers
  145. mkbitcon(shift, leng, s)
  146.     int shift;
  147.     int leng;
  148.     char *s;
  149. #else
  150. mkbitcon(int shift, int leng, char *s)
  151. #endif
  152. {
  153.     register Constp p;
  154.     register long x, y, z;
  155.     int len;
  156.     char buff[100], *fmt, *s0 = s;
  157.     static char *kind[3] = { "Binary", "Hex", "Octal" };
  158.  
  159.     p = mkconst(TYLONG);
  160.     x = y = 0;
  161.     while(--leng >= 0)
  162.         if(*s != ' ') {
  163.             z = x;
  164.             x = (x << shift) | hextoi(*s++);
  165.             y |= (((unsigned long)x) >> shift) - z;
  166.             }
  167.     /* Don't change the type to short for short constants, as
  168.      * that is dangerous -- there is no syntax for long constants
  169.      * with small values.
  170.      */
  171.     p->Const.ci = x;
  172.     if (y) {
  173.         if (--shift == 3)
  174.             shift = 1;
  175.         if ((len = (int)leng) > 60)
  176.             sprintf(buff, "%s constant '%.60s' truncated.",
  177.                 kind[shift], s0);
  178.         else
  179.             sprintf(buff, "%s constant '%.*s' truncated.",
  180.                 kind[shift], len, s0);
  181.         err(buff);
  182.         }
  183.     return( (expptr) p );
  184. }
  185.  
  186.  
  187.  
  188.  
  189.  
  190. /* mkstrcon -- Make string constant.  Allocates storage and initializes
  191.    the memory for a copy of the input Fortran-string. */
  192.  
  193.  expptr
  194. #ifdef KR_headers
  195. mkstrcon(l, v)
  196.     int l;
  197.     register char *v;
  198. #else
  199. mkstrcon(int l, register char *v)
  200. #endif
  201. {
  202.     register Constp p;
  203.     register char *s;
  204.  
  205.     p = mkconst(TYCHAR);
  206.     p->vleng = ICON(l);
  207.     p->Const.ccp = s = (char *) ckalloc(l+1);
  208.     p->Const.ccp1.blanks = 0;
  209.     while(--l >= 0)
  210.         *s++ = *v++;
  211.     *s = '\0';
  212.     return( (expptr) p );
  213. }
  214.  
  215.  
  216.  
  217. /* mkcxcon -- Make complex contsant.  A complex number is a pair of
  218.    values, each of which may be integer, real or double. */
  219.  
  220.  expptr
  221. #ifdef KR_headers
  222. mkcxcon(realp, imagp)
  223.     register expptr realp;
  224.     register expptr imagp;
  225. #else
  226. mkcxcon(register expptr realp, register expptr imagp)
  227. #endif
  228. {
  229.     int rtype, itype;
  230.     register Constp p;
  231.  
  232.     rtype = realp->headblock.vtype;
  233.     itype = imagp->headblock.vtype;
  234.  
  235.     if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
  236.     {
  237.         p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
  238.                 ? TYDCOMPLEX : tycomplex);
  239.         if (realp->constblock.vstg || imagp->constblock.vstg) {
  240.             p->vstg = 1;
  241.             p->Const.cds[0] = ISINT(rtype)
  242.                 ? string_num("", realp->constblock.Const.ci)
  243.                 : realp->constblock.vstg
  244.                     ? realp->constblock.Const.cds[0]
  245.                     : dtos(realp->constblock.Const.cd[0]);
  246.             p->Const.cds[1] = ISINT(itype)
  247.                 ? string_num("", imagp->constblock.Const.ci)
  248.                 : imagp->constblock.vstg
  249.                     ? imagp->constblock.Const.cds[0]
  250.                     : dtos(imagp->constblock.Const.cd[0]);
  251.             }
  252.         else {
  253.             p->Const.cd[0] = ISINT(rtype)
  254.                 ? realp->constblock.Const.ci
  255.                 : realp->constblock.Const.cd[0];
  256.             p->Const.cd[1] = ISINT(itype)
  257.                 ? imagp->constblock.Const.ci
  258.                 : imagp->constblock.Const.cd[0];
  259.             }
  260.     }
  261.     else
  262.     {
  263.         err("invalid complex constant");
  264.         p = (Constp)errnode();
  265.     }
  266.  
  267.     frexpr(realp);
  268.     frexpr(imagp);
  269.     return( (expptr) p );
  270. }
  271.  
  272.  
  273. /* errnode -- Allocate a new error block */
  274.  
  275.  expptr
  276. errnode(Void)
  277. {
  278.     struct Errorblock *p;
  279.     p = ALLOC(Errorblock);
  280.     p->tag = TERROR;
  281.     p->vtype = TYERROR;
  282.     return( (expptr) p );
  283. }
  284.  
  285.  
  286.  
  287.  
  288.  
  289. /* mkconv -- Make type conversion.  Cast expression   p   into type   t.
  290.    Note that casting to a character copies only the first sizeof(char)
  291.    bytes. */
  292.  
  293.  expptr
  294. #ifdef KR_headers
  295. mkconv(t, p)
  296.     register int t;
  297.     register expptr p;
  298. #else
  299. mkconv(register int t, register expptr p)
  300. #endif
  301. {
  302.     register expptr q;
  303.     register int pt, charwarn = 1;
  304.  
  305.     if (t >= 100) {
  306.         t -= 100;
  307.         charwarn = 0;
  308.         }
  309.     if(t==TYUNKNOWN || t==TYERROR)
  310.         badtype("mkconv", t);
  311.     pt = p->headblock.vtype;
  312.  
  313. /* Casting to the same type is a no-op */
  314.  
  315.     if(t == pt)
  316.         return(p);
  317.  
  318. /* If we're casting a constant which is not in the literal table ... */
  319.  
  320.     else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
  321.     {
  322.         if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
  323.             /* avoid trouble with -i2 */
  324.             p->headblock.vtype = t;
  325.             return p;
  326.             }
  327.         q = (expptr) mkconst(t);
  328.         consconv(t, &q->constblock, &p->constblock );
  329.         frexpr(p);
  330.     }
  331.     else {
  332.         if (pt == TYCHAR && t != TYADDR && charwarn
  333.                 && (!halign || p->tag != TADDR
  334.                 || p->addrblock.uname_tag != UNAM_CONST))
  335.             warn(
  336.          "ichar([first char. of] char. string) assumed for conversion to numeric");
  337.         q = opconv(p, t);
  338.         }
  339.  
  340.     if(t == TYCHAR)
  341.         q->constblock.vleng = ICON(1);
  342.     return(q);
  343. }
  344.  
  345.  
  346.  
  347. /* opconv -- Convert expression   p   to type   t   using the main
  348.    expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
  349.  
  350.  expptr
  351. #ifdef KR_headers
  352. opconv(p, t)
  353.     expptr p;
  354.     int t;
  355. #else
  356. opconv(expptr p, int t)
  357. #endif
  358. {
  359.     register expptr q;
  360.  
  361.     if (t == TYSUBR)
  362.         err("illegal use of subroutine name");
  363.     q = mkexpr(OPCONV, p, ENULL);
  364.     q->headblock.vtype = t;
  365.     return(q);
  366. }
  367.  
  368.  
  369.  
  370. /* addrof -- Create an ADDR expression operation */
  371.  
  372.  expptr
  373. #ifdef KR_headers
  374. addrof(p)
  375.     expptr p;
  376. #else
  377. addrof(expptr p)
  378. #endif
  379. {
  380.     return( mkexpr(OPADDR, p, ENULL) );
  381. }
  382.  
  383.  
  384.  
  385. /* cpexpr - Returns a new copy of input expression   p   */
  386.  
  387.  tagptr
  388. #ifdef KR_headers
  389. cpexpr(p)
  390.     register tagptr p;
  391. #else
  392. cpexpr(register tagptr p)
  393. #endif
  394. {
  395.     register tagptr e;
  396.     int tag;
  397.     register chainp ep, pp;
  398.  
  399. /* This table depends on the ordering of the T macros, e.g. TNAME */
  400.  
  401.     static int blksize[ ] =
  402.     {
  403.         0,
  404.         sizeof(struct Nameblock),
  405.         sizeof(struct Constblock),
  406.         sizeof(struct Exprblock),
  407.         sizeof(struct Addrblock),
  408.         sizeof(struct Primblock),
  409.         sizeof(struct Listblock),
  410.         sizeof(struct Impldoblock),
  411.         sizeof(struct Errorblock)
  412.     };
  413.  
  414.     if(p == NULL)
  415.         return(NULL);
  416.  
  417. /* TNAMEs are special, and don't get copied.  Each name in the current
  418.    symbol table has a unique TNAME structure. */
  419.  
  420.     if( (tag = p->tag) == TNAME)
  421.         return(p);
  422.  
  423.     e = cpblock(blksize[p->tag], (char *)p);
  424.  
  425.     switch(tag)
  426.     {
  427.     case TCONST:
  428.         if(e->constblock.vtype == TYCHAR)
  429.         {
  430.             e->constblock.Const.ccp =
  431.                 copyn((int)e->constblock.vleng->constblock.Const.ci+1,
  432.                 e->constblock.Const.ccp);
  433.             e->constblock.vleng =
  434.                 (expptr) cpexpr(e->constblock.vleng);
  435.         }
  436.     case TERROR:
  437.         break;
  438.  
  439.     case TEXPR:
  440.         e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
  441.         e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
  442.         break;
  443.  
  444.     case TLIST:
  445.         if(pp = p->listblock.listp)
  446.         {
  447.             ep = e->listblock.listp =
  448.                 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
  449.             for(pp = pp->nextp ; pp ; pp = pp->nextp)
  450.                 ep = ep->nextp =
  451.                     mkchain((char *)cpexpr((tagptr)pp->datap),
  452.                         CHNULL);
  453.         }
  454.         break;
  455.  
  456.     case TADDR:
  457.         e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
  458.         e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
  459.         e->addrblock.istemp = NO;
  460.         break;
  461.  
  462.     case TPRIM:
  463.         e->primblock.argsp = (struct Listblock *)
  464.             cpexpr((expptr)e->primblock.argsp);
  465.         e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
  466.         e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
  467.         break;
  468.  
  469.     default:
  470.         badtag("cpexpr", tag);
  471.     }
  472.  
  473.     return(e);
  474. }
  475.  
  476. /* frexpr -- Free expression -- frees up memory used by expression   p   */
  477.  
  478.  void
  479. #ifdef KR_headers
  480. frexpr(p)
  481.     register tagptr p;
  482. #else
  483. frexpr(register tagptr p)
  484. #endif
  485. {
  486.     register chainp q;
  487.  
  488.     if(p == NULL)
  489.         return;
  490.  
  491.     switch(p->tag)
  492.     {
  493.     case TCONST:
  494.         if( ISCHAR(p) )
  495.         {
  496.             free( (charptr) (p->constblock.Const.ccp) );
  497.             frexpr(p->constblock.vleng);
  498.         }
  499.         break;
  500.  
  501.     case TADDR:
  502.         if (p->addrblock.vtype > TYERROR)    /* i/o block */
  503.             break;
  504.         frexpr(p->addrblock.vleng);
  505.         frexpr(p->addrblock.memoffset);
  506.         break;
  507.  
  508.     case TERROR:
  509.         break;
  510.  
  511. /* TNAME blocks don't get free'd - probably because they're pointed to in
  512.    the hash table. 14-Jun-88 -- mwm */
  513.  
  514.     case TNAME:
  515.         return;
  516.  
  517.     case TPRIM:
  518.         frexpr((expptr)p->primblock.argsp);
  519.         frexpr(p->primblock.fcharp);
  520.         frexpr(p->primblock.lcharp);
  521.         break;
  522.  
  523.     case TEXPR:
  524.         frexpr(p->exprblock.leftp);
  525.         if(p->exprblock.rightp)
  526.             frexpr(p->exprblock.rightp);
  527.         break;
  528.  
  529.     case TLIST:
  530.         for(q = p->listblock.listp ; q ; q = q->nextp)
  531.             frexpr((tagptr)q->datap);
  532.         frchain( &(p->listblock.listp) );
  533.         break;
  534.  
  535.     default:
  536.         badtag("frexpr", p->tag);
  537.     }
  538.  
  539.     free( (charptr) p );
  540. }
  541.  
  542.  void
  543. #ifdef KR_headers
  544. wronginf(np)
  545.     Namep np;
  546. #else
  547. wronginf(Namep np)
  548. #endif
  549. {
  550.     int c, k;
  551.     warn1("fixing wrong type inferred for %.65s", np->fvarname);
  552.     np->vinftype = 0;
  553.     c = letter(np->fvarname[0]);
  554.     if ((np->vtype = impltype[c]) == TYCHAR
  555.     && (k = implleng[c]))
  556.         np->vleng = ICON(k);
  557.     }
  558.  
  559. /* fix up types in expression; replace subtrees and convert
  560.    names to address blocks */
  561.  
  562.  expptr
  563. #ifdef KR_headers
  564. fixtype(p)
  565.     register tagptr p;
  566. #else
  567. fixtype(register tagptr p)
  568. #endif
  569. {
  570.  
  571.     if(p == 0)
  572.         return(0);
  573.  
  574.     switch(p->tag)
  575.     {
  576.     case TCONST:
  577.         if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
  578.             MSKREAL) )
  579.             return( (expptr) p);
  580.  
  581.         return( (expptr) putconst((Constp)p) );
  582.  
  583.     case TADDR:
  584.         p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
  585.         return( (expptr) p);
  586.  
  587.     case TERROR:
  588.         return( (expptr) p);
  589.  
  590.     default:
  591.         badtag("fixtype", p->tag);
  592.  
  593. /* This case means that   fixexpr   can't call   fixtype   with any expr,
  594.    only a subexpr of its parameter. */
  595.  
  596.     case TEXPR:
  597.         if (((Exprp)p)->typefixed)
  598.             return (expptr)p;
  599.         return( fixexpr((Exprp)p) );
  600.  
  601.     case TLIST:
  602.         return( (expptr) p );
  603.  
  604.     case TPRIM:
  605.         if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
  606.         {
  607.             if(p->primblock.namep->vtype == TYSUBR)
  608.             {
  609.                 err("function invocation of subroutine");
  610.                 return( errnode() );
  611.             }
  612.             else {
  613.                 if (p->primblock.namep->vinftype)
  614.                     wronginf(p->primblock.namep);
  615.                 return( mkfunct(p) );
  616.                 }
  617.         }
  618.  
  619. /* The lack of args makes   p   a function name, substring reference
  620.    or variable name. */
  621.  
  622.         else    return mklhs((struct Primblock *) p, keepsubs);
  623.     }
  624. }
  625.  
  626.  
  627.  int
  628. #ifdef KR_headers
  629. badchleng(p)
  630.     register expptr p;
  631. #else
  632. badchleng(register expptr p)
  633. #endif
  634. {
  635.     if (!p->headblock.vleng) {
  636.         if (p->headblock.tag == TADDR
  637.         && p->addrblock.uname_tag == UNAM_NAME)
  638.             errstr("bad use of character*(*) variable %.60s",
  639.                 p->addrblock.user.name->fvarname);
  640.         else
  641.             err("Bad use of character*(*)");
  642.         return 1;
  643.         }
  644.     return 0;
  645.     }
  646.  
  647.  
  648.  static expptr
  649. #ifdef KR_headers
  650. cplenexpr(p)
  651.     expptr p;
  652. #else
  653. cplenexpr(expptr p)
  654. #endif
  655. {
  656.     expptr rv;
  657.  
  658.     if (badchleng(p))
  659.         return ICON(1);
  660.     rv = cpexpr(p->headblock.vleng);
  661.     if (ISCONST(p) && p->constblock.vtype == TYCHAR)
  662.         rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
  663.     return rv;
  664.     }
  665.  
  666.  
  667. /* special case tree transformations and cleanups of expression trees.
  668.    Parameter   p   should have a TEXPR tag at its root, else an error is
  669.    returned */
  670.  
  671.  expptr
  672. #ifdef KR_headers
  673. fixexpr(p)
  674.     register Exprp p;
  675. #else
  676. fixexpr(register Exprp p)
  677. #endif
  678. {
  679.     expptr lp;
  680.     register expptr rp;
  681.     register expptr q;
  682.     char *hsave;
  683.     int opcode, ltype, rtype, ptype, mtype;
  684.  
  685.     if( ISERROR(p) || p->typefixed )
  686.         return( (expptr) p );
  687.     else if(p->tag != TEXPR)
  688.         badtag("fixexpr", p->tag);
  689.     opcode = p->opcode;
  690.  
  691. /* First set the types of the left and right subexpressions */
  692.  
  693.     lp = p->leftp;
  694.     if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
  695.         lp = p->leftp = fixtype(lp);
  696.     ltype = lp->headblock.vtype;
  697.  
  698.     if(opcode==OPASSIGN && lp->tag!=TADDR)
  699.     {
  700.         err("left side of assignment must be variable");
  701.  eret:
  702.         frexpr((expptr)p);
  703.         return( errnode() );
  704.     }
  705.  
  706.     if(rp = p->rightp)
  707.     {
  708.         if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
  709.             rp = p->rightp = fixtype(rp);
  710.         rtype = rp->headblock.vtype;
  711.     }
  712.     else
  713.         rtype = 0;
  714.  
  715.     if(ltype==TYERROR || rtype==TYERROR)
  716.         goto eret;
  717.  
  718. /* Now work on the whole expression */
  719.  
  720.     /* force folding if possible */
  721.  
  722.     if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
  723.     {
  724.         q = opcode == OPCONV && lp->constblock.vtype == p->vtype
  725.             ? lp : mkexpr(opcode, lp, rp);
  726.  
  727. /* mkexpr is expected to reduce constant expressions */
  728.  
  729.         if( ISCONST(q) ) {
  730.             p->leftp = p->rightp = 0;
  731.             frexpr((expptr)p);
  732.             return(q);
  733.             }
  734.         free( (charptr) q );    /* constants did not fold */
  735.     }
  736.  
  737.     if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
  738.         goto eret;
  739.  
  740.     if (ltype == TYCHAR && ISCONST(lp)) {
  741.         if (opcode == OPCONV) {
  742.             hsave = halign;
  743.             halign = 0;
  744.             lp = (expptr)putconst((Constp)lp);
  745.             halign = hsave;
  746.             }
  747.         else
  748.             lp = (expptr)putconst((Constp)lp);
  749.         p->leftp = lp;
  750.         }
  751.     if (rtype == TYCHAR && ISCONST(rp))
  752.         p->rightp = rp = (expptr)putconst((Constp)rp);
  753.  
  754.     switch(opcode)
  755.     {
  756.     case OPCONCAT:
  757.         if(p->vleng == NULL)
  758.             p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
  759.                     cplenexpr(rp) );
  760.         break;
  761.  
  762.     case OPASSIGN:
  763.         if (rtype == TYREAL || ISLOGICAL(ptype)
  764.          || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp))
  765.             break;
  766.     case OPPLUSEQ:
  767.     case OPSTAREQ:
  768.         if(ltype == rtype)
  769.             break;
  770.         if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
  771.             break;
  772.         if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
  773.             break;
  774.         if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
  775.             && typesize[ltype]>=typesize[rtype] )
  776.                 break;
  777.  
  778. /* Cast the right hand side to match the type of the expression */
  779.  
  780.         p->rightp = fixtype( mkconv(ptype, rp) );
  781.         break;
  782.  
  783.     case OPSLASH:
  784.         if( ISCOMPLEX(rtype) )
  785.         {
  786.             p = (Exprp) call2(ptype,
  787.  
  788. /* Handle double precision complex variables */
  789.  
  790.                 ptype == TYCOMPLEX ? "c_div" : "z_div",
  791.                 mkconv(ptype, lp), mkconv(ptype, rp) );
  792.             break;
  793.         }
  794.     case OPPLUS:
  795.     case OPMINUS:
  796.     case OPSTAR:
  797.     case OPMOD:
  798.         if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
  799.             (rtype==TYREAL && ! ISCONST(rp) ) ))
  800.             break;
  801.         if( ISCOMPLEX(ptype) )
  802.             break;
  803.  
  804. /* Cast both sides of the expression to match the type of the whole
  805.    expression.  */
  806.  
  807.         if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL))
  808.             p->leftp = fixtype(mkconv(ptype,lp));
  809.         if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL))
  810.             p->rightp = fixtype(mkconv(ptype,rp));
  811.         break;
  812.  
  813.     case OPPOWER:
  814.         rp = mkpower((expptr)p);
  815.         if (rp->tag == TEXPR)
  816.             rp->exprblock.typefixed = 1;
  817.         return rp;
  818.  
  819.     case OPLT:
  820.     case OPLE:
  821.     case OPGT:
  822.     case OPGE:
  823.     case OPEQ:
  824.     case OPNE:
  825.         if(ltype == rtype)
  826.             break;
  827.         if (htype) {
  828.             if (ltype == TYCHAR) {
  829.                 p->leftp = fixtype(mkconv(rtype,lp));
  830.                 break;
  831.                 }
  832.             if (rtype == TYCHAR) {
  833.                 p->rightp = fixtype(mkconv(ltype,rp));
  834.                 break;
  835.                 }
  836.             }
  837.         mtype = cktype(OPMINUS, ltype, rtype);
  838.         if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL))
  839.             break;
  840.         if( ISCOMPLEX(mtype) )
  841.             break;
  842.         if(ltype != mtype)
  843.             p->leftp = fixtype(mkconv(mtype,lp));
  844.         if(rtype != mtype)
  845.             p->rightp = fixtype(mkconv(mtype,rp));
  846.         break;
  847.  
  848.     case OPCONV:
  849.         ptype = cktype(OPCONV, p->vtype, ltype);
  850.         if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
  851.          && !ISCOMPLEX(ptype))
  852.         {
  853.             lp->exprblock.rightp =
  854.                 fixtype( mkconv(ptype, lp->exprblock.rightp) );
  855.             free( (charptr) p );
  856.             p = (Exprp) lp;
  857.         }
  858.         break;
  859.  
  860.     case OPADDR:
  861.         if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
  862.             Fatal("addr of addr");
  863.         break;
  864.  
  865.     case OPCOMMA:
  866.     case OPQUEST:
  867.     case OPCOLON:
  868.         break;
  869.  
  870.     case OPMIN:
  871.     case OPMAX:
  872.     case OPMIN2:
  873.     case OPMAX2:
  874.     case OPDMIN:
  875.     case OPDMAX:
  876.     case OPABS:
  877.     case OPDABS:
  878.         ptype = p->vtype;
  879.         break;
  880.  
  881.     default:
  882.         break;
  883.     }
  884.  
  885.     p->vtype = ptype;
  886.     p->typefixed = 1;
  887.     return((expptr) p);
  888. }
  889.  
  890.  
  891. /* fix an argument list, taking due care for special first level cases */
  892.  
  893.  int
  894. #ifdef KR_headers
  895. fixargs(doput, p0)
  896.     int doput;
  897.     struct Listblock *p0;
  898. #else
  899. fixargs(int doput, struct Listblock *p0)
  900. #endif
  901.     /* doput is true if constants need to be passed by reference */
  902. {
  903.     register chainp p;
  904.     register tagptr q, t;
  905.     register int qtag;
  906.     int nargs;
  907.  
  908.     nargs = 0;
  909.     if(p0)
  910.         for(p = p0->listp ; p ; p = p->nextp)
  911.         {
  912.             ++nargs;
  913.             q = (tagptr)p->datap;
  914.             qtag = q->tag;
  915.             if(qtag == TCONST)
  916.             {
  917.  
  918. /* Call putconst() to store values in a constant table.  Since even
  919.    constants must be passed by reference, this can optimize on the storage
  920.    required */
  921.  
  922.                 p->datap = doput ? (char *)putconst((Constp)q)
  923.                          : (char *)q;
  924.             }
  925.  
  926. /* Take a function name and turn it into an Addr.  This only happens when
  927.    nothing else has figured out the function beforehand */
  928.  
  929.             else if(qtag==TPRIM && q->primblock.argsp==0 &&
  930.                 q->primblock.namep->vclass==CLPROC &&
  931.                 q->primblock.namep->vprocclass != PTHISPROC)
  932.                 p->datap = (char *)mkaddr(q->primblock.namep);
  933.  
  934.             else if(qtag==TPRIM && q->primblock.argsp==0 &&
  935.                 q->primblock.namep->vdim!=NULL)
  936.                 p->datap = (char *)mkscalar(q->primblock.namep);
  937.  
  938.             else if(qtag==TPRIM && q->primblock.argsp==0 &&
  939.                 q->primblock.namep->vdovar &&
  940.                 (t = (tagptr) memversion(q->primblock.namep)) )
  941.                 p->datap = (char *)fixtype(t);
  942.             else
  943.                 p->datap = (char *)fixtype(q);
  944.         }
  945.     return(nargs);
  946. }
  947.  
  948.  
  949.  
  950. /* mkscalar -- only called by   fixargs   above, and by some routines in
  951.    io.c */
  952.  
  953.  Addrp
  954. #ifdef KR_headers
  955. mkscalar(np)
  956.     register Namep np;
  957. #else
  958. mkscalar(register Namep np)
  959. #endif
  960. {
  961.     register Addrp ap;
  962.  
  963.     vardcl(np);
  964.     ap = mkaddr(np);
  965.  
  966.     /* The prolog causes array arguments to point to the
  967.      * (0,...,0) element, unless subscript checking is on.
  968.      */
  969.     if( !checksubs && np->vstg==STGARG)
  970.     {
  971.         register struct Dimblock *dp;
  972.         dp = np->vdim;
  973.         frexpr(ap->memoffset);
  974.         ap->memoffset = mkexpr(OPSTAR,
  975.             (np->vtype==TYCHAR ?
  976.             cpexpr(np->vleng) :
  977.             (tagptr)ICON(typesize[np->vtype]) ),
  978.             cpexpr(dp->baseoffset) );
  979.     }
  980.     return(ap);
  981. }
  982.  
  983.  
  984.  static void
  985. #ifdef KR_headers
  986. adjust_arginfo(np)
  987.     register Namep np;
  988. #else
  989. adjust_arginfo(register Namep np)
  990. #endif
  991.             /* adjust arginfo to omit the length arg for the
  992.                arg that we now know to be a character-valued
  993.                function */
  994. {
  995.     struct Entrypoint *ep;
  996.     register chainp args;
  997.     Argtypes *at;
  998.  
  999.     for(ep = entries; ep; ep = ep->entnextp)
  1000.         for(args = ep->arglist; args; args = args->nextp)
  1001.             if (np == (Namep)args->datap
  1002.             && (at = ep->entryname->arginfo))
  1003.                 --at->nargs;
  1004.     }
  1005.  
  1006.  
  1007.  
  1008.  expptr
  1009. #ifdef KR_headers
  1010. mkfunct(p0)
  1011.     expptr p0;
  1012. #else
  1013. mkfunct(expptr p0)
  1014. #endif
  1015. {
  1016.     register struct Primblock *p = (struct Primblock *)p0;
  1017.     struct Entrypoint *ep;
  1018.     Addrp ap;
  1019.     Extsym *extp;
  1020.     register Namep np;
  1021.     register expptr q;
  1022.     extern chainp new_procs;
  1023.     int k, nargs;
  1024.     int class;
  1025.  
  1026.     if(p->tag != TPRIM)
  1027.         return( errnode() );
  1028.  
  1029.     np = p->namep;
  1030.     class = np->vclass;
  1031.  
  1032.  
  1033.     if(class == CLUNKNOWN)
  1034.     {
  1035.         np->vclass = class = CLPROC;
  1036.         if(np->vstg == STGUNKNOWN)
  1037.         {
  1038.             if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
  1039.                 && (zflag || !(*(struct Intrpacked *)&k).f4
  1040.                     || dcomplex_seen))
  1041.             {
  1042.                 np->vstg = STGINTR;
  1043.                 np->vardesc.varno = k;
  1044.                 np->vprocclass = PINTRINSIC;
  1045.             }
  1046.             else
  1047.             {
  1048.                 extp = mkext(np->fvarname,
  1049.                     addunder(np->cvarname));
  1050.                 extp->extstg = STGEXT;
  1051.                 np->vstg = STGEXT;
  1052.                 np->vardesc.varno = extp - extsymtab;
  1053.                 np->vprocclass = PEXTERNAL;
  1054.             }
  1055.         }
  1056.         else if(np->vstg==STGARG)
  1057.         {
  1058.             if(np->vtype == TYCHAR) {
  1059.             adjust_arginfo(np);
  1060.             if (np->vpassed) {
  1061.                 char wbuf[160], *who;
  1062.                 who = np->fvarname;
  1063.                 sprintf(wbuf, "%s%s%s\n\t%s%s%s",
  1064.                     "Character-valued dummy procedure ",
  1065.                     who, " not declared EXTERNAL.",
  1066.             "Code may be wrong for previous function calls having ",
  1067.                     who, " as a parameter.");
  1068.                 warn(wbuf);
  1069.                 }
  1070.             }
  1071.             np->vprocclass = PEXTERNAL;
  1072.         }
  1073.     }
  1074.  
  1075.     if(class != CLPROC) {
  1076.         if (np->vstg == STGCOMMON)
  1077.             fatalstr(
  1078.              "Cannot invoke common variable %.50s as a function.",
  1079.                 np->fvarname);
  1080.         errstr("%.80s cannot be called.", np->fvarname);
  1081.         goto error;
  1082.         }
  1083.  
  1084. /* F77 doesn't allow subscripting of function calls */
  1085.  
  1086.     if(p->fcharp || p->lcharp)
  1087.     {
  1088.         err("no substring of function call");
  1089.         goto error;
  1090.     }
  1091.     impldcl(np);
  1092.     np->vimpltype = 0;    /* invoking as function ==> inferred type */
  1093.     np->vcalled = 1;
  1094.     nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
  1095.  
  1096.     switch(np->vprocclass)
  1097.     {
  1098.     case PEXTERNAL:
  1099.         if(np->vtype == TYUNKNOWN)
  1100.         {
  1101.             dclerr("attempt to use untyped function", np);
  1102.             np->vtype = dflttype[letter(np->fvarname[0])];
  1103.         }
  1104.         ap = mkaddr(np);
  1105.         if (!extsymtab[np->vardesc.varno].extseen) {
  1106.             new_procs = mkchain((char *)np, new_procs);
  1107.             extsymtab[np->vardesc.varno].extseen = 1;
  1108.             }
  1109. call:
  1110.         q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
  1111.         q->exprblock.vtype = np->vtype;
  1112.         if(np->vleng)
  1113.             q->exprblock.vleng = (expptr) cpexpr(np->vleng);
  1114.         break;
  1115.  
  1116.     case PINTRINSIC:
  1117.         q = intrcall(np, p->argsp, nargs);
  1118.         break;
  1119.  
  1120.     case PSTFUNCT:
  1121.         q = stfcall(np, p->argsp);
  1122.         break;
  1123.  
  1124.     case PTHISPROC:
  1125.         warn("recursive call");
  1126.  
  1127. /* entries   is the list of multiple entry points */
  1128.  
  1129.         for(ep = entries ; ep ; ep = ep->entnextp)
  1130.             if(ep->enamep == np)
  1131.                 break;
  1132.         if(ep == NULL)
  1133.             Fatal("mkfunct: impossible recursion");
  1134.  
  1135.         ap = builtin(np->vtype, ep->entryname->cextname, -2);
  1136.         /* the negative last arg prevents adding */
  1137.         /* this name to the list of used builtins */
  1138.         goto call;
  1139.  
  1140.     default:
  1141.         fatali("mkfunct: impossible vprocclass %d",
  1142.             (int) (np->vprocclass) );
  1143.     }
  1144.     free( (charptr) p );
  1145.     return(q);
  1146.  
  1147. error:
  1148.     frexpr((expptr)p);
  1149.     return( errnode() );
  1150. }
  1151.  
  1152.  
  1153.  
  1154.  static expptr
  1155. #ifdef KR_headers
  1156. stfcall(np, actlist)
  1157.     Namep np;
  1158.     struct Listblock *actlist;
  1159. #else
  1160. stfcall(Namep np, struct Listblock *actlist)
  1161. #endif
  1162. {
  1163.     register chainp actuals;
  1164.     int nargs;
  1165.     chainp oactp, formals;
  1166.     int type;
  1167.     expptr Ln, Lq, q, q1, rhs, ap;
  1168.     Namep tnp;
  1169.     register struct Rplblock *rp;
  1170.     struct Rplblock *tlist;
  1171.  
  1172.     if (np->arginfo) {
  1173.         errstr("statement function %.66s calls itself.",
  1174.             np->fvarname);
  1175.         return ICON(0);
  1176.         }
  1177.     np->arginfo = (Argtypes *)np;    /* arbitrary nonzero value */
  1178.     if(actlist)
  1179.     {
  1180.         actuals = actlist->listp;
  1181.         free( (charptr) actlist);
  1182.     }
  1183.     else
  1184.         actuals = NULL;
  1185.     oactp = actuals;
  1186.  
  1187.     nargs = 0;
  1188.     tlist = NULL;
  1189.     if( (type = np->vtype) == TYUNKNOWN)
  1190.     {
  1191.         dclerr("attempt to use untyped statement function", np);
  1192.         type = np->vtype = dflttype[letter(np->fvarname[0])];
  1193.     }
  1194.     formals = (chainp) np->varxptr.vstfdesc->datap;
  1195.     rhs = (expptr) (np->varxptr.vstfdesc->nextp);
  1196.  
  1197.     /* copy actual arguments into temporaries */
  1198.     while(actuals!=NULL && formals!=NULL)
  1199.     {
  1200.         if (!(tnp = (Namep) formals->datap)) {
  1201.             /* buggy statement function declaration */
  1202.             q = ICON(1);
  1203.             goto done;
  1204.             }
  1205.         rp = ALLOC(Rplblock);
  1206.         rp->rplnp = tnp;
  1207.         ap = fixtype((tagptr)actuals->datap);
  1208.         if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
  1209.             && (ap->tag==TCONST || ap->tag==TADDR) )
  1210.         {
  1211.  
  1212. /* If actuals are constants or variable names, no temporaries are required */
  1213.             rp->rplvp = (expptr) ap;
  1214.             rp->rplxp = NULL;
  1215.             rp->rpltag = ap->tag;
  1216.         }
  1217.         else    {
  1218.             rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
  1219.             rp -> rplxp = NULL;
  1220.             putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
  1221.             if((rp->rpltag = rp->rplvp->tag) == TERROR)
  1222.                 err("disagreement of argument types in statement function call");
  1223.         }
  1224.         rp->rplnextp = tlist;
  1225.         tlist = rp;
  1226.         actuals = actuals->nextp;
  1227.         formals = formals->nextp;
  1228.         ++nargs;
  1229.     }
  1230.  
  1231.     if(actuals!=NULL || formals!=NULL)
  1232.         err("statement function definition and argument list differ");
  1233.  
  1234.     /*
  1235.    now push down names involved in formal argument list, then
  1236.    evaluate rhs of statement function definition in this environment
  1237. */
  1238.  
  1239.     if(tlist)    /* put tlist in front of the rpllist */
  1240.     {
  1241.         for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
  1242.             ;
  1243.         rp->rplnextp = rpllist;
  1244.         rpllist = tlist;
  1245.     }
  1246.  
  1247. /* So when the expression finally gets evaled, that evaluator must read
  1248.    from the globl   rpllist   14-jun-88 mwm */
  1249.  
  1250.     q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
  1251.  
  1252.     /* get length right of character-valued statement functions... */
  1253.     if (type == TYCHAR
  1254.      && (Ln = np->vleng)
  1255.      && q->tag != TERROR
  1256.      && (Lq = q->exprblock.vleng)
  1257.      && (Lq->tag != TCONST
  1258.         || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
  1259.         q1 = (expptr) mktmp(type, Ln);
  1260.         putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
  1261.         q = q1;
  1262.         }
  1263.  
  1264.     /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
  1265.     while(--nargs >= 0)
  1266.     {
  1267.         if(rpllist->rplxp)
  1268.             q = mkexpr(OPCOMMA, rpllist->rplxp, q);
  1269.         rp = rpllist->rplnextp;
  1270.         frexpr(rpllist->rplvp);
  1271.         free((char *)rpllist);
  1272.         rpllist = rp;
  1273.     }
  1274.  done:
  1275.     frchain( &oactp );
  1276.     np->arginfo = 0;
  1277.     return(q);
  1278. }
  1279.  
  1280.  
  1281. static int replaced;
  1282.  
  1283. /* mkplace -- Figure out the proper storage class for the input name and
  1284.    return an addrp with the appropriate stuff */
  1285.  
  1286.  Addrp
  1287. #ifdef KR_headers
  1288. mkplace(np)
  1289.     register Namep np;
  1290. #else
  1291. mkplace(register Namep np)
  1292. #endif
  1293. {
  1294.     register Addrp s;
  1295.     register struct Rplblock *rp;
  1296.     int regn;
  1297.  
  1298.     /* is name on the replace list? */
  1299.  
  1300.     for(rp = rpllist ; rp ; rp = rp->rplnextp)
  1301.     {
  1302.         if(np == rp->rplnp)
  1303.         {
  1304.             replaced = 1;
  1305.             if(rp->rpltag == TNAME)
  1306.             {
  1307.                 np = (Namep) (rp->rplvp);
  1308.                 break;
  1309.             }
  1310.             else    return( (Addrp) cpexpr(rp->rplvp) );
  1311.         }
  1312.     }
  1313.  
  1314.     /* is variable a DO index in a register ? */
  1315.  
  1316.     if(np->vdovar && ( (regn = inregister(np)) >= 0) )
  1317.         if(np->vtype == TYERROR)
  1318.             return((Addrp) errnode() );
  1319.         else
  1320.         {
  1321.             s = ALLOC(Addrblock);
  1322.             s->tag = TADDR;
  1323.             s->vstg = STGREG;
  1324.             s->vtype = TYIREG;
  1325.             s->memno = regn;
  1326.             s->memoffset = ICON(0);
  1327.             s -> uname_tag = UNAM_NAME;
  1328.             s -> user.name = np;
  1329.             return(s);
  1330.         }
  1331.  
  1332.     if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
  1333.         errstr("external %.60s used as a variable", np->fvarname);
  1334.     vardcl(np);
  1335.     return(mkaddr(np));
  1336. }
  1337.  
  1338.  static expptr
  1339. #ifdef KR_headers
  1340. subskept(p, a)
  1341.     struct Primblock *p;
  1342.     Addrp a;
  1343. #else
  1344. subskept(struct Primblock *p, Addrp a)
  1345. #endif
  1346. {
  1347.     expptr ep;
  1348.     struct Listblock *Lb;
  1349.     chainp cp;
  1350.  
  1351.     if (a->uname_tag != UNAM_NAME)
  1352.         erri("subskept: uname_tag %d", a->uname_tag);
  1353.     a->user.name->vrefused = 1;
  1354.     a->user.name->visused = 1;
  1355.     a->uname_tag = UNAM_REF;
  1356.     Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
  1357.     for(cp = Lb->listp; cp; cp = cp->nextp)
  1358.         cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
  1359.     if (a->vtype == TYCHAR) {
  1360.         ep = p->fcharp    ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
  1361.                 : ICON(0);
  1362.         Lb->listp = mkchain((char *)ep, Lb->listp);
  1363.         }
  1364.     return (expptr)Lb;
  1365.     }
  1366.  
  1367.  static int doing_vleng;
  1368.  
  1369. /* mklhs -- Compute the actual address of the given expression; account
  1370.    for array subscripts, stack offset, and substring offsets.  The f -> C
  1371.    translator will need this only to worry about the subscript stuff */
  1372.  
  1373.  expptr
  1374. #ifdef KR_headers
  1375. mklhs(p, subkeep)
  1376.     register struct Primblock *p;
  1377.     int subkeep;
  1378. #else
  1379. mklhs(register struct Primblock *p, int subkeep)
  1380. #endif
  1381. {
  1382.     register Addrp s;
  1383.     Namep np;
  1384.  
  1385.     if(p->tag != TPRIM)
  1386.         return( (expptr) p );
  1387.     np = p->namep;
  1388.  
  1389.     replaced = 0;
  1390.     s = mkplace(np);
  1391.     if(s->tag!=TADDR || s->vstg==STGREG)
  1392.     {
  1393.         free( (charptr) p );
  1394.         return( (expptr) s );
  1395.     }
  1396.     s->parenused = p->parenused;
  1397.  
  1398.     /* compute the address modified by subscripts */
  1399.  
  1400.     if (!replaced)
  1401.         s->memoffset = (subkeep && np->vdim
  1402.                 && (np->vdim->ndim > 1 || np->vtype == TYCHAR
  1403.                 && (!ISCONST(np->vleng)
  1404.                   || np->vleng->constblock.Const.ci != 1)))
  1405.                 ? subskept(p,s)
  1406.                 : mkexpr(OPPLUS, s->memoffset, suboffset(p) );
  1407.     frexpr((expptr)p->argsp);
  1408.     p->argsp = NULL;
  1409.  
  1410.     /* now do substring part */
  1411.  
  1412.     if(p->fcharp || p->lcharp)
  1413.     {
  1414.         if(np->vtype != TYCHAR)
  1415.             errstr("substring of noncharacter %s", np->fvarname);
  1416.         else    {
  1417.             if(p->lcharp == NULL)
  1418.                 p->lcharp = (expptr) cpexpr(s->vleng);
  1419.             if(p->fcharp) {
  1420.                 doing_vleng = 1;
  1421.                 s->vleng = fixtype(mkexpr(OPMINUS,
  1422.                         p->lcharp,
  1423.                     mkexpr(OPMINUS, p->fcharp, ICON(1) )));
  1424.                 doing_vleng = 0;
  1425.                 }
  1426.             else    {
  1427.                 frexpr(s->vleng);
  1428.                 s->vleng = p->lcharp;
  1429.             }
  1430.         }
  1431.     }
  1432.  
  1433.     s->vleng = fixtype( s->vleng );
  1434.     s->memoffset = fixtype( s->memoffset );
  1435.     free( (charptr) p );
  1436.     return( (expptr) s );
  1437. }
  1438.  
  1439.  
  1440.  
  1441.  
  1442.  
  1443. /* deregister -- remove a register allocation from the list; assumes that
  1444.    names are deregistered in stack order (LIFO order - Last In First Out) */
  1445.  
  1446.  void
  1447. #ifdef KR_headers
  1448. deregister(np)
  1449.     Namep np;
  1450. #else
  1451. deregister(Namep np)
  1452. #endif
  1453. {
  1454.     if(nregvar>0 && regnamep[nregvar-1]==np)
  1455.     {
  1456.         --nregvar;
  1457.     }
  1458. }
  1459.  
  1460.  
  1461.  
  1462.  
  1463. /* memversion -- moves a DO index REGISTER into a memory location; other
  1464.    objects are passed through untouched */
  1465.  
  1466.  Addrp
  1467. #ifdef KR_headers
  1468. memversion(np)
  1469.     register Namep np;
  1470. #else
  1471. memversion(register Namep np)
  1472. #endif
  1473. {
  1474.     register Addrp s;
  1475.  
  1476.     if(np->vdovar==NO || (inregister(np)<0) )
  1477.         return(NULL);
  1478.     np->vdovar = NO;
  1479.     s = mkplace(np);
  1480.     np->vdovar = YES;
  1481.     return(s);
  1482. }
  1483.  
  1484.  
  1485.  
  1486. /* inregister -- looks for the input name in the global list   regnamep */
  1487.  
  1488.  int
  1489. #ifdef KR_headers
  1490. inregister(np)
  1491.     register Namep np;
  1492. #else
  1493. inregister(register Namep np)
  1494. #endif
  1495. {
  1496.     register int i;
  1497.  
  1498.     for(i = 0 ; i < nregvar ; ++i)
  1499.         if(regnamep[i] == np)
  1500.             return( regnum[i] );
  1501.     return(-1);
  1502. }
  1503.  
  1504.  
  1505.  
  1506. /* suboffset -- Compute the offset from the start of the array, given the
  1507.    subscripts as arguments */
  1508.  
  1509.  expptr
  1510. #ifdef KR_headers
  1511. suboffset(p)
  1512.     register struct Primblock *p;
  1513. #else
  1514. suboffset(register struct Primblock *p)
  1515. #endif
  1516. {
  1517.     int n;
  1518.     expptr si, size;
  1519.     chainp cp;
  1520.     expptr e, e1, offp, prod;
  1521.     struct Dimblock *dimp;
  1522.     expptr sub[MAXDIM+1];
  1523.     register Namep np;
  1524.  
  1525.     np = p->namep;
  1526.     offp = ICON(0);
  1527.     n = 0;
  1528.     if(p->argsp)
  1529.         for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
  1530.         {
  1531.             si = fixtype(cpexpr((tagptr)cp->datap));
  1532.             if (!ISINT(si->headblock.vtype)) {
  1533.                 NOEXT("non-integer subscript");
  1534.                 si = mkconv(TYLONG, si);
  1535.                 }
  1536.             sub[n++] = si;
  1537.             if(n > maxdim)
  1538.             {
  1539.                 erri("more than %d subscripts", maxdim);
  1540.                 break;
  1541.             }
  1542.         }
  1543.  
  1544.     dimp = np->vdim;
  1545.     if(n>0 && dimp==NULL)
  1546.         errstr("subscripts on scalar variable %.68s", np->fvarname);
  1547.     else if(dimp && dimp->ndim!=n)
  1548.         errstr("wrong number of subscripts on %.68s", np->fvarname);
  1549.     else if(n > 0)
  1550.     {
  1551.         prod = sub[--n];
  1552.         while( --n >= 0)
  1553.             prod = mkexpr(OPPLUS, sub[n],
  1554.                 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
  1555.         if(checksubs || np->vstg!=STGARG)
  1556.             prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
  1557.  
  1558. /* Add in the run-time bounds check */
  1559.  
  1560.         if(checksubs)
  1561.             prod = subcheck(np, prod);
  1562.         size = np->vtype == TYCHAR ?
  1563.             (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
  1564.         prod = mkexpr(OPSTAR, prod, size);
  1565.         offp = mkexpr(OPPLUS, offp, prod);
  1566.     }
  1567.  
  1568. /* Check for substring indicator */
  1569.  
  1570.     if(p->fcharp && np->vtype==TYCHAR) {
  1571.         e = p->fcharp;
  1572.         e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
  1573.         if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
  1574.             e = (expptr)mktmp(TYLONG, ENULL);
  1575.             putout(putassign(cpexpr(e), e1));
  1576.             p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
  1577.             e1 = e;
  1578.             }
  1579.         offp = mkexpr(OPPLUS, offp, e1);
  1580.         }
  1581.     return(offp);
  1582. }
  1583.  
  1584.  
  1585.  
  1586.  
  1587.  expptr
  1588. #ifdef KR_headers
  1589. subcheck(np, p)
  1590.     Namep np;
  1591.     register expptr p;
  1592. #else
  1593. subcheck(Namep np, register expptr p)
  1594. #endif
  1595. {
  1596.     struct Dimblock *dimp;
  1597.     expptr t, checkvar, checkcond, badcall;
  1598.  
  1599.     dimp = np->vdim;
  1600.     if(dimp->nelt == NULL)
  1601.         return(p);    /* don't check arrays with * bounds */
  1602.     np->vlastdim = 0;
  1603.     if( ISICON(p) )
  1604.     {
  1605.  
  1606. /* check for negative (constant) offset */
  1607.  
  1608.         if(p->constblock.Const.ci < 0)
  1609.             goto badsub;
  1610.         if( ISICON(dimp->nelt) )
  1611.  
  1612. /* see if constant offset exceeds the array declaration */
  1613.  
  1614.             if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
  1615.                 return(p);
  1616.             else
  1617.                 goto badsub;
  1618.     }
  1619.  
  1620. /* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
  1621.    Now find a register to use for run-time bounds checking */
  1622.  
  1623.     if(p->tag==TADDR && p->addrblock.vstg==STGREG)
  1624.     {
  1625.         checkvar = (expptr) cpexpr(p);
  1626.         t = p;
  1627.     }
  1628.     else    {
  1629.         checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
  1630.         t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
  1631.     }
  1632.     checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
  1633.     if( ! ISICON(p) )
  1634.         checkcond = mkexpr(OPAND, checkcond,
  1635.             mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
  1636.  
  1637. /* Construct the actual test */
  1638.  
  1639.     badcall = call4(p->headblock.vtype, "s_rnge",
  1640.         mkstrcon(strlen(np->fvarname), np->fvarname),
  1641.         mkconv(TYLONG,  cpexpr(checkvar)),
  1642.         mkstrcon(strlen(procname), procname),
  1643.         ICON(lineno) );
  1644.     badcall->exprblock.opcode = OPCCALL;
  1645.     p = mkexpr(OPQUEST, checkcond,
  1646.         mkexpr(OPCOLON, checkvar, badcall));
  1647.  
  1648.     return(p);
  1649.  
  1650. badsub:
  1651.     frexpr(p);
  1652.     errstr("subscript on variable %s out of range", np->fvarname);
  1653.     return ( ICON(0) );
  1654. }
  1655.  
  1656.  
  1657.  
  1658.  
  1659.  Addrp
  1660. #ifdef KR_headers
  1661. mkaddr(p)
  1662.     register Namep p;
  1663. #else
  1664. mkaddr(register Namep p)
  1665. #endif
  1666. {
  1667.     Extsym *extp;
  1668.     register Addrp t;
  1669.     int k;
  1670.  
  1671.     switch( p->vstg)
  1672.     {
  1673.     case STGAUTO:
  1674.         if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
  1675.             return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
  1676.         goto other;
  1677.  
  1678.     case STGUNKNOWN:
  1679.         if(p->vclass != CLPROC)
  1680.             break;    /* Error */
  1681.         extp = mkext(p->fvarname, addunder(p->cvarname));
  1682.         extp->extstg = STGEXT;
  1683.         p->vstg = STGEXT;
  1684.         p->vardesc.varno = extp - extsymtab;
  1685.         p->vprocclass = PEXTERNAL;
  1686.         if ((extp->exproto || infertypes)
  1687.         && (p->vtype == TYUNKNOWN || p->vimpltype)
  1688.         && (k = extp->extype))
  1689.             inferdcl(p, k);
  1690.  
  1691.  
  1692.     case STGCOMMON:
  1693.     case STGEXT:
  1694.     case STGBSS:
  1695.     case STGINIT:
  1696.     case STGEQUIV:
  1697.     case STGARG:
  1698.     case STGLENG:
  1699.  other:
  1700.         t = ALLOC(Addrblock);
  1701.         t->tag = TADDR;
  1702.  
  1703.         t->vclass = p->vclass;
  1704.         t->vtype = p->vtype;
  1705.         t->vstg = p->vstg;
  1706.         t->memno = p->vardesc.varno;
  1707.         t->memoffset = ICON(p->voffset);
  1708.         if (p->vdim)
  1709.             t->isarray = 1;
  1710.         if(p->vleng)
  1711.         {
  1712.             t->vleng = (expptr) cpexpr(p->vleng);
  1713.             if( ISICON(t->vleng) )
  1714.                 t->varleng = t->vleng->constblock.Const.ci;
  1715.         }
  1716.  
  1717. /* Keep the original name around for the C code generation */
  1718.  
  1719.         t -> uname_tag = UNAM_NAME;
  1720.         t -> user.name = p;
  1721.         return(t);
  1722.  
  1723.     case STGINTR:
  1724.  
  1725.         return ( intraddr (p));
  1726.  
  1727.     case STGSTFUNCT:
  1728.  
  1729.         errstr("invalid use of statement function %.64s.", p->fvarname);
  1730.         return putconst((Constp)ICON(0));
  1731.     }
  1732.     badstg("mkaddr", p->vstg);
  1733.     /* NOT REACHED */ return 0;
  1734. }
  1735.  
  1736.  
  1737.  
  1738.  
  1739. /* mkarg -- create storage for a new parameter.  This is called when a
  1740.    function returns a string (for the return value, which is the first
  1741.    parameter), or when a variable-length string is passed to a function. */
  1742.  
  1743.  Addrp
  1744. #ifdef KR_headers
  1745. mkarg(type, argno)
  1746.     int type;
  1747.     int argno;
  1748. #else
  1749. mkarg(int type, int argno)
  1750. #endif
  1751. {
  1752.     register Addrp p;
  1753.  
  1754.     p = ALLOC(Addrblock);
  1755.     p->tag = TADDR;
  1756.     p->vtype = type;
  1757.     p->vclass = CLVAR;
  1758.  
  1759. /* TYLENG is the type of the field holding the length of a character string */
  1760.  
  1761.     p->vstg = (type==TYLENG ? STGLENG : STGARG);
  1762.     p->memno = argno;
  1763.     return(p);
  1764. }
  1765.  
  1766.  
  1767.  
  1768.  
  1769. /* mkprim -- Create a PRIM (primary/primitive) block consisting of a
  1770.    Nameblock (or Paramblock), arguments (actual params or array
  1771.    subscripts) and substring bounds.  Requires that   v   have lots of
  1772.    extra (uninitialized) storage, since it could be a paramblock or
  1773.    nameblock */
  1774.  
  1775.  expptr
  1776. #ifdef KR_headers
  1777. mkprim(v0, args, substr)
  1778.     Namep v0;
  1779.     struct Listblock *args;
  1780.     chainp substr;
  1781. #else
  1782. mkprim(Namep v0, struct Listblock *args, chainp substr)
  1783. #endif
  1784. {
  1785.     typedef union {
  1786.         struct Paramblock paramblock;
  1787.         struct Nameblock nameblock;
  1788.         struct Headblock headblock;
  1789.         } *Primu;
  1790.     register Primu v = (Primu)v0;
  1791.     register struct Primblock *p;
  1792.  
  1793.     if(v->headblock.vclass == CLPARAM)
  1794.     {
  1795.  
  1796. /* v   is to be a Paramblock */
  1797.  
  1798.         if(args || substr)
  1799.         {
  1800.             errstr("no qualifiers on parameter name %s",
  1801.                 v->paramblock.fvarname);
  1802.             frexpr((expptr)args);
  1803.             if(substr)
  1804.             {
  1805.                 frexpr((tagptr)substr->datap);
  1806.                 frexpr((tagptr)substr->nextp->datap);
  1807.                 frchain(&substr);
  1808.             }
  1809.             frexpr((expptr)v);
  1810.             return( errnode() );
  1811.         }
  1812.         return( (expptr) cpexpr(v->paramblock.paramval) );
  1813.     }
  1814.  
  1815.     p = ALLOC(Primblock);
  1816.     p->tag = TPRIM;
  1817.     p->vtype = v->nameblock.vtype;
  1818.  
  1819. /* v   is to be a Nameblock */
  1820.  
  1821.     p->namep = (Namep) v;
  1822.     p->argsp = args;
  1823.     if(substr)
  1824.     {
  1825.         p->fcharp = (expptr) substr->datap;
  1826.         p->lcharp = (expptr) substr->nextp->datap;
  1827.         frchain(&substr);
  1828.     }
  1829.     return( (expptr) p);
  1830. }
  1831.  
  1832.  
  1833.  
  1834. /* vardcl -- attempt to fill out the Name template for variable   v.
  1835.    This function is called on identifiers known to be variables or
  1836.    recursive references to the same function */
  1837.  
  1838.  void
  1839. #ifdef KR_headers
  1840. vardcl(v)
  1841.     register Namep v;
  1842. #else
  1843. vardcl(register Namep v)
  1844. #endif
  1845. {
  1846.     struct Dimblock *t;
  1847.     expptr neltp;
  1848.     extern int doing_stmtfcn;
  1849.  
  1850.     if(v->vclass == CLUNKNOWN) {
  1851.         v->vclass = CLVAR;
  1852.         if (v->vinftype) {
  1853.             v->vtype = TYUNKNOWN;
  1854.             if (v->vdcldone) {
  1855.                 v->vdcldone = 0;
  1856.                 impldcl(v);
  1857.                 }
  1858.             }
  1859.         }
  1860.     if(v->vdcldone)
  1861.         return;
  1862.     if(v->vclass == CLNAMELIST)
  1863.         return;
  1864.  
  1865.     if(v->vtype == TYUNKNOWN)
  1866.         impldcl(v);
  1867.     else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
  1868.     {
  1869.         dclerr("used as variable", v);
  1870.         return;
  1871.     }
  1872.     if(v->vstg==STGUNKNOWN) {
  1873.         if (doing_stmtfcn) {
  1874.             /* neither declare this variable if its only use */
  1875.             /* is in defining a stmt function, nor complain  */
  1876.             /* that it is never used */
  1877.             v->vimpldovar = 1;
  1878.             return;
  1879.             }
  1880.         v->vstg = implstg[ letter(v->fvarname[0]) ];
  1881.         v->vimplstg = 1;
  1882.         }
  1883.  
  1884. /* Compute the actual storage location, i.e. offsets from base addresses,
  1885.    possibly the stack pointer */
  1886.  
  1887.     switch(v->vstg)
  1888.     {
  1889.     case STGBSS:
  1890.         v->vardesc.varno = ++lastvarno;
  1891.         break;
  1892.     case STGAUTO:
  1893.         if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
  1894.             break;
  1895.         if(t = v->vdim)
  1896.             if( (neltp = t->nelt) && ISCONST(neltp) ) ;
  1897.             else
  1898.                 dclerr("adjustable automatic array", v);
  1899.         break;
  1900.  
  1901.     default:
  1902.         break;
  1903.     }
  1904.     v->vdcldone = YES;
  1905. }
  1906.  
  1907.  
  1908.  
  1909. /* Set the implicit type declaration of parameter   p   based on its first
  1910.    letter */
  1911.  
  1912.  void
  1913. #ifdef KR_headers
  1914. impldcl(p)
  1915.     register Namep p;
  1916. #else
  1917. impldcl(register Namep p)
  1918. #endif
  1919. {
  1920.     register int k;
  1921.     int type;
  1922.     ftnint leng;
  1923.  
  1924.     if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
  1925.         return;
  1926.     if(p->vtype == TYUNKNOWN)
  1927.     {
  1928.         k = letter(p->fvarname[0]);
  1929.         type = impltype[ k ];
  1930.         leng = implleng[ k ];
  1931.         if(type == TYUNKNOWN)
  1932.         {
  1933.             if(p->vclass == CLPROC)
  1934.                 return;
  1935.             dclerr("attempt to use undefined variable", p);
  1936.             type = dflttype[k];
  1937.             leng = 0;
  1938.         }
  1939.         settype(p, type, leng);
  1940.         p->vimpltype = 1;
  1941.     }
  1942. }
  1943.  
  1944.  void
  1945. #ifdef KR_headers
  1946. inferdcl(np, type)
  1947.     Namep np;
  1948.     int type;
  1949. #else
  1950. inferdcl(Namep np, int type)
  1951. #endif
  1952. {
  1953.     int k = impltype[letter(np->fvarname[0])];
  1954.     if (k != type) {
  1955.         np->vinftype = 1;
  1956.         np->vtype = type;
  1957.         frexpr(np->vleng);
  1958.         np->vleng = 0;
  1959.         }
  1960.     np->vimpltype = 0;
  1961.     np->vinfproc = 1;
  1962.     }
  1963.  
  1964.  LOCAL int
  1965. #ifdef KR_headers
  1966. zeroconst(e)
  1967.     expptr e;
  1968. #else
  1969. zeroconst(expptr e)
  1970. #endif
  1971. {
  1972.     register Constp c = (Constp) e;
  1973.     if (c->tag == TCONST)
  1974.         switch(c->vtype) {
  1975.         case TYINT1:
  1976.         case TYSHORT:
  1977.         case TYLONG:
  1978. #ifdef TYQUAD
  1979.         case TYQUAD:
  1980. #endif
  1981.             return c->Const.ci == 0;
  1982.  
  1983.         case TYREAL:
  1984.         case TYDREAL:
  1985.             if (c->vstg == 1)
  1986.                 return !strcmp(c->Const.cds[0],"0.");
  1987.             return c->Const.cd[0] == 0.;
  1988.  
  1989.         case TYCOMPLEX:
  1990.         case TYDCOMPLEX:
  1991.             if (c->vstg == 1)
  1992.                 return !strcmp(c->Const.cds[0],"0.")
  1993.                     && !strcmp(c->Const.cds[1],"0.");
  1994.             return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.;
  1995.         }
  1996.     return 0;
  1997.     }
  1998.  
  1999.  
  2000. #define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
  2001. #define COMMUTE    { e = lp;  lp = rp;  rp = e; }
  2002.  
  2003. /* mkexpr -- Make expression, and simplify constant subcomponents (tree
  2004.    order is not preserved).  Assumes that   lp   is nonempty, and uses
  2005.    fold()   to simplify adjacent constants */
  2006.  
  2007.  expptr
  2008. #ifdef KR_headers
  2009. mkexpr(opcode, lp, rp)
  2010.     int opcode;
  2011.     register expptr lp;
  2012.     register expptr rp;
  2013. #else
  2014. mkexpr(int opcode, register expptr lp, register expptr rp)
  2015. #endif
  2016. {
  2017.     register expptr e, e1;
  2018.     int etype;
  2019.     int ltype, rtype;
  2020.     int ltag, rtag;
  2021.     long L;
  2022.     static long divlineno;
  2023.  
  2024.     ltype = lp->headblock.vtype;
  2025.     ltag = lp->tag;
  2026.     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
  2027.     {
  2028.         rtype = rp->headblock.vtype;
  2029.         rtag = rp->tag;
  2030.     }
  2031.     else rtype = 0;
  2032.  
  2033.     etype = cktype(opcode, ltype, rtype);
  2034.     if(etype == TYERROR)
  2035.         goto error;
  2036.  
  2037.     switch(opcode)
  2038.     {
  2039.         /* check for multiplication by 0 and 1 and addition to 0 */
  2040.  
  2041.     case OPSTAR:
  2042.         if( ISCONST(lp) )
  2043.             COMMUTE
  2044.  
  2045.         if( ISICON(rp) )
  2046.             {
  2047.                 if(rp->constblock.Const.ci == 0)
  2048.                     goto retright;
  2049.                 goto mulop;
  2050.             }
  2051.         break;
  2052.  
  2053.     case OPSLASH:
  2054.     case OPMOD:
  2055.         if( zeroconst(rp) && lineno != divlineno ) {
  2056.             warn("attempted division by zero");
  2057.             divlineno = lineno;
  2058.             }
  2059.         if(opcode == OPMOD)
  2060.             break;
  2061.  
  2062. /* Handle multiplying or dividing by 1, -1 */
  2063.  
  2064. mulop:
  2065.         if( ISICON(rp) )
  2066.         {
  2067.             if(rp->constblock.Const.ci == 1)
  2068.                 goto retleft;
  2069.  
  2070.             if(rp->constblock.Const.ci == -1)
  2071.             {
  2072.                 frexpr(rp);
  2073.                 return( mkexpr(OPNEG, lp, ENULL) );
  2074.             }
  2075.         }
  2076.  
  2077. /* Group all constants together.  In particular,
  2078.  
  2079.     (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
  2080.     (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
  2081. */
  2082.  
  2083.         if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp
  2084.                 || !ISICON(lp->exprblock.rightp))
  2085.             break;
  2086.  
  2087.         if (lp->exprblock.opcode == OPLSHIFT) {
  2088.             L = 1 << lp->exprblock.rightp->constblock.Const.ci;
  2089.             if (opcode == OPSTAR || ISICON(rp) &&
  2090.                     !(L % rp->constblock.Const.ci)) {
  2091.                 lp->exprblock.opcode = OPSTAR;
  2092.                 lp->exprblock.rightp->constblock.Const.ci = L;
  2093.                 }
  2094.             }
  2095.  
  2096.         if (lp->exprblock.opcode == OPSTAR) {
  2097.             if(opcode == OPSTAR)
  2098.                 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
  2099.             else if(ISICON(rp) &&
  2100.                 (lp->exprblock.rightp->constblock.Const.ci %
  2101.                 rp->constblock.Const.ci) == 0)
  2102.                 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
  2103.             else    break;
  2104.  
  2105.             e1 = lp->exprblock.leftp;
  2106.             free( (charptr) lp );
  2107.             return( mkexpr(OPSTAR, e1, e) );
  2108.             }
  2109.         break;
  2110.  
  2111.  
  2112.     case OPPLUS:
  2113.         if( ISCONST(lp) )
  2114.             COMMUTE
  2115.                 goto addop;
  2116.  
  2117.     case OPMINUS:
  2118.         if( ICONEQ(lp, 0) )
  2119.         {
  2120.             frexpr(lp);
  2121.             return( mkexpr(OPNEG, rp, ENULL) );
  2122.         }
  2123.  
  2124.         if( ISCONST(rp) && is_negatable((Constp)rp))
  2125.         {
  2126.             opcode = OPPLUS;
  2127.             consnegop((Constp)rp);
  2128.         }
  2129.  
  2130. /* Group constants in an addition expression (also subtraction, since the
  2131.    subtracted value was negated above).  In particular,
  2132.  
  2133.     (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
  2134. */
  2135.  
  2136. addop:
  2137.         if( ISICON(rp) )
  2138.         {
  2139.             if(rp->constblock.Const.ci == 0)
  2140.                 goto retleft;
  2141.             if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
  2142.             {
  2143.                 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
  2144.                 e1 = lp->exprblock.leftp;
  2145.                 free( (charptr) lp );
  2146.                 return( mkexpr(OPPLUS, e1, e) );
  2147.             }
  2148.         }
  2149.         if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
  2150.             /* check for (i [+const]) - (i [+const]) */
  2151.             if (lp->tag == TPRIM)
  2152.                 e = lp;
  2153.             else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
  2154.                     && lp->exprblock.rightp->tag == TCONST) {
  2155.                 e = lp->exprblock.leftp;
  2156.                 if (e->tag != TPRIM)
  2157.                     break;
  2158.                 }
  2159.             else
  2160.                 break;
  2161.             if (e->primblock.argsp)
  2162.                 break;
  2163.             if (rp->tag == TPRIM)
  2164.                 e1 = rp;
  2165.             else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
  2166.                     && rp->exprblock.rightp->tag == TCONST) {
  2167.                 e1 = rp->exprblock.leftp;
  2168.                 if (e1->tag != TPRIM)
  2169.                     break;
  2170.                 }
  2171.             else
  2172.                 break;
  2173.             if (e->primblock.namep != e1->primblock.namep
  2174.                     || e1->primblock.argsp)
  2175.                 break;
  2176.             L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
  2177.             if (e1 != rp)
  2178.                 L -= rp->exprblock.rightp->constblock.Const.ci;
  2179.             frexpr(lp);
  2180.             frexpr(rp);
  2181.             return ICON(L);
  2182.             }
  2183.  
  2184.         break;
  2185.  
  2186.  
  2187.     case OPPOWER:
  2188.         break;
  2189.  
  2190. /* Eliminate outermost double negations */
  2191.  
  2192.     case OPNEG:
  2193.     case OPNEG1:
  2194.         if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
  2195.         {
  2196.             e = lp->exprblock.leftp;
  2197.             free( (charptr) lp );
  2198.             return(e);
  2199.         }
  2200.         break;
  2201.  
  2202. /* Eliminate outermost double NOTs */
  2203.  
  2204.     case OPNOT:
  2205.         if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
  2206.         {
  2207.             e = lp->exprblock.leftp;
  2208.             free( (charptr) lp );
  2209.             return(e);
  2210.         }
  2211.         break;
  2212.  
  2213.     case OPCALL:
  2214.     case OPCCALL:
  2215.         etype = ltype;
  2216.         if(rp!=NULL && rp->listblock.listp==NULL)
  2217.         {
  2218.             free( (charptr) rp );
  2219.             rp = NULL;
  2220.         }
  2221.         break;
  2222.  
  2223.     case OPAND:
  2224.     case OPOR:
  2225.         if( ISCONST(lp) )
  2226.             COMMUTE
  2227.  
  2228.                 if( ISCONST(rp) )
  2229.             {
  2230.                 if(rp->constblock.Const.ci == 0)
  2231.                     if(opcode == OPOR)
  2232.                         goto retleft;
  2233.                     else
  2234.                         goto retright;
  2235.                 else if(opcode == OPOR)
  2236.                     goto retright;
  2237.                 else
  2238.                     goto retleft;
  2239.             }
  2240.     case OPEQV:
  2241.     case OPNEQV:
  2242.  
  2243.     case OPBITAND:
  2244.     case OPBITOR:
  2245.     case OPBITXOR:
  2246.     case OPBITNOT:
  2247.     case OPLSHIFT:
  2248.     case OPRSHIFT:
  2249.  
  2250.     case OPLT:
  2251.     case OPGT:
  2252.     case OPLE:
  2253.     case OPGE:
  2254.     case OPEQ:
  2255.     case OPNE:
  2256.  
  2257.     case OPCONCAT:
  2258.         break;
  2259.     case OPMIN:
  2260.     case OPMAX:
  2261.     case OPMIN2:
  2262.     case OPMAX2:
  2263.     case OPDMIN:
  2264.     case OPDMAX:
  2265.  
  2266.     case OPASSIGN:
  2267.     case OPASSIGNI:
  2268.     case OPPLUSEQ:
  2269.     case OPSTAREQ:
  2270.     case OPMINUSEQ:
  2271.     case OPSLASHEQ:
  2272.     case OPMODEQ:
  2273.     case OPLSHIFTEQ:
  2274.     case OPRSHIFTEQ:
  2275.     case OPBITANDEQ:
  2276.     case OPBITXOREQ:
  2277.     case OPBITOREQ:
  2278.  
  2279.     case OPCONV:
  2280.     case OPADDR:
  2281.     case OPWHATSIN:
  2282.  
  2283.     case OPCOMMA:
  2284.     case OPCOMMA_ARG:
  2285.     case OPQUEST:
  2286.     case OPCOLON:
  2287.     case OPDOT:
  2288.     case OPARROW:
  2289.     case OPIDENTITY:
  2290.     case OPCHARCAST:
  2291.     case OPABS:
  2292.     case OPDABS:
  2293.         break;
  2294.  
  2295.     default:
  2296.         badop("mkexpr", opcode);
  2297.     }
  2298.  
  2299.     e = (expptr) ALLOC(Exprblock);
  2300.     e->exprblock.tag = TEXPR;
  2301.     e->exprblock.opcode = opcode;
  2302.     e->exprblock.vtype = etype;
  2303.     e->exprblock.leftp = lp;
  2304.     e->exprblock.rightp = rp;
  2305.     if(ltag==TCONST && (rp==0 || rtag==TCONST) )
  2306.         e = fold(e);
  2307.     return(e);
  2308.  
  2309. retleft:
  2310.     frexpr(rp);
  2311.     if (lp->tag == TPRIM)
  2312.         lp->primblock.parenused = 1;
  2313.     return(lp);
  2314.  
  2315. retright:
  2316.     frexpr(lp);
  2317.     if (rp->tag == TPRIM)
  2318.         rp->primblock.parenused = 1;
  2319.     return(rp);
  2320.  
  2321. error:
  2322.     frexpr(lp);
  2323.     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
  2324.         frexpr(rp);
  2325.     return( errnode() );
  2326. }
  2327.  
  2328. #define ERR(s)   { errs = s; goto error; }
  2329.  
  2330. /* cktype -- Check and return the type of the expression */
  2331.  
  2332. #ifdef KR_headers
  2333. cktype(op, lt, rt)
  2334.     register int op;
  2335.     register int lt;
  2336.     register int rt;
  2337. #else
  2338. cktype(register int op, register int lt, register int rt)
  2339. #endif
  2340. {
  2341.     char *errs;
  2342.  
  2343.     if(lt==TYERROR || rt==TYERROR)
  2344.         goto error1;
  2345.  
  2346.     if(lt==TYUNKNOWN)
  2347.         return(TYUNKNOWN);
  2348.     if(rt==TYUNKNOWN)
  2349.  
  2350. /* If not unary operation, return UNKNOWN */
  2351.  
  2352.         if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
  2353.             return(TYUNKNOWN);
  2354.  
  2355.     switch(op)
  2356.     {
  2357.     case OPPLUS:
  2358.     case OPMINUS:
  2359.     case OPSTAR:
  2360.     case OPSLASH:
  2361.     case OPPOWER:
  2362.     case OPMOD:
  2363.         if( ISNUMERIC(lt) && ISNUMERIC(rt) )
  2364.             return( maxtype(lt, rt) );
  2365.         ERR("nonarithmetic operand of arithmetic operator")
  2366.  
  2367.     case OPNEG:
  2368.     case OPNEG1:
  2369.         if( ISNUMERIC(lt) )
  2370.             return(lt);
  2371.         ERR("nonarithmetic operand of negation")
  2372.  
  2373.     case OPNOT:
  2374.         if(ISLOGICAL(lt))
  2375.             return(lt);
  2376.         ERR("NOT of nonlogical")
  2377.  
  2378.     case OPAND:
  2379.     case OPOR:
  2380.     case OPEQV:
  2381.     case OPNEQV:
  2382.         if(ISLOGICAL(lt) && ISLOGICAL(rt))
  2383.             return( maxtype(lt, rt) );
  2384.         ERR("nonlogical operand of logical operator")
  2385.  
  2386.     case OPLT:
  2387.     case OPGT:
  2388.     case OPLE:
  2389.     case OPGE:
  2390.     case OPEQ:
  2391.     case OPNE:
  2392.         if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
  2393.         {
  2394.             if(lt != rt){
  2395.                 if (htype
  2396.                     && (lt == TYCHAR && ISNUMERIC(rt)
  2397.                      || rt == TYCHAR && ISNUMERIC(lt)))
  2398.                         return TYLOGICAL;
  2399.                 ERR("illegal comparison")
  2400.                 }
  2401.         }
  2402.  
  2403.         else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
  2404.         {
  2405.             if(op!=OPEQ && op!=OPNE)
  2406.                 ERR("order comparison of complex data")
  2407.         }
  2408.  
  2409.         else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
  2410.             ERR("comparison of nonarithmetic data")
  2411.                 return(TYLOGICAL);
  2412.  
  2413.     case OPCONCAT:
  2414.         if(lt==TYCHAR && rt==TYCHAR)
  2415.             return(TYCHAR);
  2416.         ERR("concatenation of nonchar data")
  2417.  
  2418.     case OPCALL:
  2419.     case OPCCALL:
  2420.     case OPIDENTITY:
  2421.         return(lt);
  2422.  
  2423.     case OPADDR:
  2424.     case OPCHARCAST:
  2425.         return(TYADDR);
  2426.  
  2427.     case OPCONV:
  2428.         if(rt == 0)
  2429.             return(0);
  2430.         if(lt==TYCHAR && ISINT(rt) )
  2431.             return(TYCHAR);
  2432.         if (ISLOGICAL(lt) && ISLOGICAL(rt))
  2433.             return lt;
  2434.     case OPASSIGN:
  2435.     case OPASSIGNI:
  2436.     case OPMINUSEQ:
  2437.     case OPPLUSEQ:
  2438.     case OPSTAREQ:
  2439.     case OPSLASHEQ:
  2440.     case OPMODEQ:
  2441.     case OPLSHIFTEQ:
  2442.     case OPRSHIFTEQ:
  2443.     case OPBITANDEQ:
  2444.     case OPBITXOREQ:
  2445.     case OPBITOREQ:
  2446.         if( ISINT(lt) && rt==TYCHAR)
  2447.             return(lt);
  2448.         if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
  2449.             return lt;
  2450.         if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
  2451.             if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
  2452.                 || (lt!=rt))
  2453.             {
  2454.                 ERR("impossible conversion")
  2455.             }
  2456.         return(lt);
  2457.  
  2458.     case OPMIN:
  2459.     case OPMAX:
  2460.     case OPDMIN:
  2461.     case OPDMAX:
  2462.     case OPMIN2:
  2463.     case OPMAX2:
  2464.     case OPBITOR:
  2465.     case OPBITAND:
  2466.     case OPBITXOR:
  2467.     case OPBITNOT:
  2468.     case OPLSHIFT:
  2469.     case OPRSHIFT:
  2470.     case OPWHATSIN:
  2471.     case OPABS:
  2472.     case OPDABS:
  2473.         return(lt);
  2474.  
  2475.     case OPCOMMA:
  2476.     case OPCOMMA_ARG:
  2477.     case OPQUEST:
  2478.     case OPCOLON:        /* Only checks the rightmost type because
  2479.                    of C language definition (rightmost
  2480.                    comma-expr is the value of the expr) */
  2481.         return(rt);
  2482.  
  2483.     case OPDOT:
  2484.     case OPARROW:
  2485.         return (lt);
  2486.     default:
  2487.         badop("cktype", op);
  2488.     }
  2489. error:
  2490.     err(errs);
  2491. error1:
  2492.     return(TYERROR);
  2493. }
  2494.  
  2495.  static void
  2496. intovfl(Void)
  2497. { err("overflow simplifying integer constants."); }
  2498.  
  2499. /* fold -- simplifies constant expressions; it assumes that e -> leftp and
  2500.    e -> rightp are TCONST or NULL */
  2501.  
  2502.  expptr
  2503. #ifdef KR_headers
  2504. fold(e)
  2505.     register expptr e;
  2506. #else
  2507. fold(register expptr e)
  2508. #endif
  2509. {
  2510.     Constp p;
  2511.     register expptr lp, rp;
  2512.     int etype, mtype, ltype, rtype, opcode;
  2513.     int i, bl, ll, lr;
  2514.     char *q, *s;
  2515.     struct Constblock lcon, rcon;
  2516.     ftnint L;
  2517.     double d;
  2518.  
  2519.     opcode = e->exprblock.opcode;
  2520.     etype = e->exprblock.vtype;
  2521.  
  2522.     lp = e->exprblock.leftp;
  2523.     ltype = lp->headblock.vtype;
  2524.     rp = e->exprblock.rightp;
  2525.  
  2526.     if(rp == 0)
  2527.         switch(opcode)
  2528.         {
  2529.         case OPNOT:
  2530.             lp->constblock.Const.ci = ! lp->constblock.Const.ci;
  2531.  retlp:
  2532.             e->exprblock.leftp = 0;
  2533.             frexpr(e);
  2534.             return(lp);
  2535.  
  2536.         case OPBITNOT:
  2537.             lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
  2538.             goto retlp;
  2539.  
  2540.         case OPNEG:
  2541.         case OPNEG1:
  2542.             consnegop((Constp)lp);
  2543.             goto retlp;
  2544.  
  2545.         case OPCONV:
  2546.         case OPADDR:
  2547.             return(e);
  2548.  
  2549.         case OPABS:
  2550.         case OPDABS:
  2551.             switch(ltype) {
  2552.                 case TYINT1:
  2553.                 case TYSHORT:
  2554.                 case TYLONG:
  2555. #ifdef TYQUAD
  2556.                 case TYQUAD:
  2557. #endif
  2558.                 if ((L = lp->constblock.Const.ci) < 0) {
  2559.                     lp->constblock.Const.ci = -L;
  2560.                     if (L != -lp->constblock.Const.ci)
  2561.                         intovfl();
  2562.                     }
  2563.                 goto retlp;
  2564.                 case TYREAL:
  2565.                 case TYDREAL:
  2566.                 if (lp->constblock.vstg) {
  2567.                     s = lp->constblock.Const.cds[0];
  2568.                     if (*s == '-')
  2569.                     lp->constblock.Const.cds[0] = s + 1;
  2570.                     goto retlp;
  2571.                 }
  2572.                 if ((d = lp->constblock.Const.cd[0]) < 0.)
  2573.                     lp->constblock.Const.cd[0] = -d;
  2574.                 case TYCOMPLEX:
  2575.                 case TYDCOMPLEX:
  2576.                 return e;    /* lazy way out */
  2577.                 }
  2578.         default:
  2579.             badop("fold", opcode);
  2580.         }
  2581.  
  2582.     rtype = rp->headblock.vtype;
  2583.  
  2584.     p = ALLOC(Constblock);
  2585.     p->tag = TCONST;
  2586.     p->vtype = etype;
  2587.     p->vleng = e->exprblock.vleng;
  2588.  
  2589.     switch(opcode)
  2590.     {
  2591.     case OPCOMMA:
  2592.     case OPCOMMA_ARG:
  2593.     case OPQUEST:
  2594.     case OPCOLON:
  2595.         goto ereturn;
  2596.  
  2597.     case OPAND:
  2598.         p->Const.ci = lp->constblock.Const.ci &&
  2599.             rp->constblock.Const.ci;
  2600.         break;
  2601.  
  2602.     case OPOR:
  2603.         p->Const.ci = lp->constblock.Const.ci ||
  2604.             rp->constblock.Const.ci;
  2605.         break;
  2606.  
  2607.     case OPEQV:
  2608.         p->Const.ci = lp->constblock.Const.ci ==
  2609.             rp->constblock.Const.ci;
  2610.         break;
  2611.  
  2612.     case OPNEQV:
  2613.         p->Const.ci = lp->constblock.Const.ci !=
  2614.             rp->constblock.Const.ci;
  2615.         break;
  2616.  
  2617.     case OPBITAND:
  2618.         p->Const.ci = lp->constblock.Const.ci &
  2619.             rp->constblock.Const.ci;
  2620.         break;
  2621.  
  2622.     case OPBITOR:
  2623.         p->Const.ci = lp->constblock.Const.ci |
  2624.             rp->constblock.Const.ci;
  2625.         break;
  2626.  
  2627.     case OPBITXOR:
  2628.         p->Const.ci = lp->constblock.Const.ci ^
  2629.             rp->constblock.Const.ci;
  2630.         break;
  2631.  
  2632.     case OPLSHIFT:
  2633.         p->Const.ci = lp->constblock.Const.ci <<
  2634.             rp->constblock.Const.ci;
  2635.         if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci)
  2636.                 != lp->constblock.Const.ci)
  2637.             intovfl();
  2638.         break;
  2639.  
  2640.     case OPRSHIFT:
  2641.         p->Const.ci = lp->constblock.Const.ci >>
  2642.             rp->constblock.Const.ci;
  2643.         break;
  2644.  
  2645.     case OPCONCAT:
  2646.         ll = lp->constblock.vleng->constblock.Const.ci;
  2647.         lr = rp->constblock.vleng->constblock.Const.ci;
  2648.         bl = lp->constblock.Const.ccp1.blanks;
  2649.         p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
  2650.         p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
  2651.         p->vleng = ICON(ll+lr+bl);
  2652.         s = lp->constblock.Const.ccp;
  2653.         for(i = 0 ; i < ll ; ++i)
  2654.             *q++ = *s++;
  2655.         for(i = 0 ; i < bl ; i++)
  2656.             *q++ = ' ';
  2657.         s = rp->constblock.Const.ccp;
  2658.         for(i = 0; i < lr; ++i)
  2659.             *q++ = *s++;
  2660.         break;
  2661.  
  2662.  
  2663.     case OPPOWER:
  2664.         if( !ISINT(rtype)
  2665.          || rp->constblock.Const.ci < 0 && zeroconst(lp))
  2666.             goto ereturn;
  2667.         conspower(p, (Constp)lp, rp->constblock.Const.ci);
  2668.         break;
  2669.  
  2670.     case OPSLASH:
  2671.         if (zeroconst(rp))
  2672.             goto ereturn;
  2673.         /* no break */
  2674.  
  2675.     default:
  2676.         if(ltype == TYCHAR)
  2677.         {
  2678.             lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
  2679.                 rp->constblock.Const.ccp,
  2680.                 lp->constblock.vleng->constblock.Const.ci,
  2681.                 rp->constblock.vleng->constblock.Const.ci);
  2682.             rcon.Const.ci = 0;
  2683.             mtype = tyint;
  2684.         }
  2685.         else    {
  2686.             mtype = maxtype(ltype, rtype);
  2687.             consconv(mtype, &lcon, &lp->constblock);
  2688.             consconv(mtype, &rcon, &rp->constblock);
  2689.         }
  2690.         consbinop(opcode, mtype, p, &lcon, &rcon);
  2691.         break;
  2692.     }
  2693.  
  2694.     frexpr(e);
  2695.     return( (expptr) p );
  2696.  ereturn:
  2697.     free((char *)p);
  2698.     return e;
  2699. }
  2700.  
  2701.  
  2702.  
  2703. /* assign constant l = r , doing coercion */
  2704.  
  2705.  void
  2706. #ifdef KR_headers
  2707. consconv(lt, lc, rc)
  2708.     int lt;
  2709.     register Constp lc;
  2710.     register Constp rc;
  2711. #else
  2712. consconv(int lt, register Constp lc, register Constp rc)
  2713. #endif
  2714. {
  2715.     int rt = rc->vtype;
  2716.     register union Constant *lv = &lc->Const, *rv = &rc->Const;
  2717.  
  2718.     lc->vtype = lt;
  2719.     if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
  2720.         memcpy((char *)lv, (char *)rv, sizeof(union Constant));
  2721.         lc->vstg = rc->vstg;
  2722.         if (ISCOMPLEX(lt) && ISREAL(rt)) {
  2723.             if (rc->vstg)
  2724.                 lv->cds[1] = cds("0",CNULL);
  2725.             else
  2726.                 lv->cd[1] = 0.;
  2727.             }
  2728.         return;
  2729.         }
  2730.     lc->vstg = 0;
  2731.  
  2732.     switch(lt)
  2733.     {
  2734.  
  2735. /* Casting to character means just copying the first sizeof (character)
  2736.    bytes into a new 1 character string.  This is weird. */
  2737.  
  2738.     case TYCHAR:
  2739.         *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
  2740.         lv->ccp1.blanks = 0;
  2741.         break;
  2742.  
  2743.     case TYINT1:
  2744.     case TYSHORT:
  2745.     case TYLONG:
  2746. #ifdef TYQUAD
  2747.     case TYQUAD:
  2748. #endif
  2749.         if(rt == TYCHAR)
  2750.             lv->ci = rv->ccp[0];
  2751.         else if( ISINT(rt) )
  2752.             lv->ci = rv->ci;
  2753.         else    lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
  2754.  
  2755.         break;
  2756.  
  2757.     case TYCOMPLEX:
  2758.     case TYDCOMPLEX:
  2759.         lv->cd[1] = 0.;
  2760.         lv->cd[0] = rv->ci;
  2761.         break;
  2762.  
  2763.     case TYREAL:
  2764.     case TYDREAL:
  2765.         lv->cd[0] = rv->ci;
  2766.         break;
  2767.  
  2768.     case TYLOGICAL:
  2769.     case TYLOGICAL1:
  2770.     case TYLOGICAL2:
  2771.         lv->ci = rv->ci;
  2772.         break;
  2773.     }
  2774. }
  2775.  
  2776.  
  2777.  
  2778. /* Negate constant value -- changes the input node's value */
  2779.  
  2780.  void
  2781. #ifdef KR_headers
  2782. consnegop(p)
  2783.     register Constp p;
  2784. #else
  2785. consnegop(register Constp p)
  2786. #endif
  2787. {
  2788.     register char *s;
  2789.     ftnint L;
  2790.  
  2791.     if (p->vstg) {
  2792.         if (ISCOMPLEX(p->vtype)) {
  2793.             s = p->Const.cds[1];
  2794.             p->Const.cds[1] = *s == '-' ? s+1
  2795.                     : *s == '0' ? s : s-1;
  2796.             }
  2797.         s = p->Const.cds[0];
  2798.         p->Const.cds[0] = *s == '-' ? s+1
  2799.                 : *s == '0' ? s : s-1;
  2800.         return;
  2801.         }
  2802.     switch(p->vtype)
  2803.     {
  2804.     case TYINT1:
  2805.     case TYSHORT:
  2806.     case TYLONG:
  2807. #ifdef TYQUAD
  2808.     case TYQUAD:
  2809. #endif
  2810.         p->Const.ci = -(L = p->Const.ci);
  2811.         if (L != -p->Const.ci)
  2812.             intovfl();
  2813.         break;
  2814.  
  2815.     case TYCOMPLEX:
  2816.     case TYDCOMPLEX:
  2817.         p->Const.cd[1] = - p->Const.cd[1];
  2818.         /* fall through and do the real parts */
  2819.     case TYREAL:
  2820.     case TYDREAL:
  2821.         p->Const.cd[0] = - p->Const.cd[0];
  2822.         break;
  2823.     default:
  2824.         badtype("consnegop", p->vtype);
  2825.     }
  2826. }
  2827.  
  2828.  
  2829.  
  2830. /* conspower -- Expand out an exponentiation */
  2831.  
  2832.  LOCAL void
  2833. #ifdef KR_headers
  2834. conspower(p, ap, n)
  2835.     Constp p;
  2836.     Constp ap;
  2837.     ftnint n;
  2838. #else
  2839. conspower(Constp p, Constp ap, ftnint n)
  2840. #endif
  2841. {
  2842.     register union Constant *powp = &p->Const;
  2843.     register int type;
  2844.     struct Constblock x, x0;
  2845.  
  2846.     if (n == 1) {
  2847.         memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
  2848.         return;
  2849.         }
  2850.  
  2851.     switch(type = ap->vtype)    /* pow = 1 */
  2852.     {
  2853.     case TYINT1:
  2854.     case TYSHORT:
  2855.     case TYLONG:
  2856. #ifdef TYQUAD
  2857.     case TYQUAD:
  2858. #endif
  2859.         powp->ci = 1;
  2860.         break;
  2861.     case TYCOMPLEX:
  2862.     case TYDCOMPLEX:
  2863.         powp->cd[1] = 0;
  2864.     case TYREAL:
  2865.     case TYDREAL:
  2866.         powp->cd[0] = 1;
  2867.         break;
  2868.     default:
  2869.         badtype("conspower", type);
  2870.     }
  2871.  
  2872.     if(n == 0)
  2873.         return;
  2874.     switch(type)    /* x0 = ap */
  2875.     {
  2876.     case TYINT1:
  2877.     case TYSHORT:
  2878.     case TYLONG:
  2879. #ifdef TYQUAD
  2880.     case TYQUAD:
  2881. #endif
  2882.         x0.Const.ci = ap->Const.ci;
  2883.         break;
  2884.     case TYCOMPLEX:
  2885.     case TYDCOMPLEX:
  2886.         x0.Const.cd[1] =
  2887.             ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
  2888.     case TYREAL:
  2889.     case TYDREAL:
  2890.         x0.Const.cd[0] =
  2891.             ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
  2892.         break;
  2893.     }
  2894.     x0.vtype = type;
  2895.     x0.vstg = 0;
  2896.     if(n < 0)
  2897.     {
  2898.         if( ISINT(type) )
  2899.         {
  2900.             err("integer ** negative number");
  2901.             return;
  2902.         }
  2903.         else if (!x0.Const.cd[0]
  2904.                 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
  2905.             err("0.0 ** negative number");
  2906.             return;
  2907.             }
  2908.         n = -n;
  2909.         consbinop(OPSLASH, type, &x, p, &x0);
  2910.     }
  2911.     else
  2912.         consbinop(OPSTAR, type, &x, p, &x0);
  2913.  
  2914.     for( ; ; )
  2915.     {
  2916.         if(n & 01)
  2917.             consbinop(OPSTAR, type, p, p, &x);
  2918.         if(n >>= 1)
  2919.             consbinop(OPSTAR, type, &x, &x, &x);
  2920.         else
  2921.             break;
  2922.     }
  2923. }
  2924.  
  2925.  
  2926.  
  2927. /* do constant operation cp = a op b -- assumes that   ap and bp   have data
  2928.    matching the input   type */
  2929.  
  2930.  LOCAL void
  2931. #ifdef KR_headers
  2932. consbinop(opcode, type, cpp, app, bpp)
  2933.     int opcode;
  2934.     int type;
  2935.     Constp cpp;
  2936.     Constp app;
  2937.     Constp bpp;
  2938. #else
  2939. consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp)
  2940. #endif
  2941. {
  2942.     register union Constant *ap = &app->Const,
  2943.                 *bp = &bpp->Const,
  2944.                 *cp = &cpp->Const;
  2945.     int k;
  2946.     double ad[2], bd[2], temp;
  2947.     ftnint a, b;
  2948.  
  2949.     cpp->vstg = 0;
  2950.  
  2951.     if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
  2952.         ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
  2953.         bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
  2954.         if (ISCOMPLEX(type)) {
  2955.             ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
  2956.             bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
  2957.             }
  2958.         }
  2959.     switch(opcode)
  2960.     {
  2961.     case OPPLUS:
  2962.         switch(type)
  2963.         {
  2964.         case TYINT1:
  2965.         case TYSHORT:
  2966.         case TYLONG:
  2967. #ifdef TYQUAD
  2968.         case TYQUAD:
  2969. #endif
  2970.             cp->ci = ap->ci + bp->ci;
  2971.             if (ap->ci != cp->ci - bp->ci)
  2972.                 intovfl();
  2973.             break;
  2974.         case TYCOMPLEX:
  2975.         case TYDCOMPLEX:
  2976.             cp->cd[1] = ad[1] + bd[1];
  2977.         case TYREAL:
  2978.         case TYDREAL:
  2979.             cp->cd[0] = ad[0] + bd[0];
  2980.             break;
  2981.         }
  2982.         break;
  2983.  
  2984.     case OPMINUS:
  2985.         switch(type)
  2986.         {
  2987.         case TYINT1:
  2988.         case TYSHORT:
  2989.         case TYLONG:
  2990. #ifdef TYQUAD
  2991.         case TYQUAD:
  2992. #endif
  2993.             cp->ci = ap->ci - bp->ci;
  2994.             if (ap->ci != bp->ci + cp->ci)
  2995.                 intovfl();
  2996.             break;
  2997.         case TYCOMPLEX:
  2998.         case TYDCOMPLEX:
  2999.             cp->cd[1] = ad[1] - bd[1];
  3000.         case TYREAL:
  3001.         case TYDREAL:
  3002.             cp->cd[0] = ad[0] - bd[0];
  3003.             break;
  3004.         }
  3005.         break;
  3006.  
  3007.     case OPSTAR:
  3008.         switch(type)
  3009.         {
  3010.         case TYINT1:
  3011.         case TYSHORT:
  3012.         case TYLONG:
  3013. #ifdef TYQUAD
  3014.         case TYQUAD:
  3015. #endif
  3016.             cp->ci = (a = ap->ci) * (b = bp->ci);
  3017.             if (a && cp->ci / a != b)
  3018.                 intovfl();
  3019.             break;
  3020.         case TYREAL:
  3021.         case TYDREAL:
  3022.             cp->cd[0] = ad[0] * bd[0];
  3023.             break;
  3024.         case TYCOMPLEX:
  3025.         case TYDCOMPLEX:
  3026.             temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
  3027.             cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
  3028.             cp->cd[0] = temp;
  3029.             break;
  3030.         }
  3031.         break;
  3032.     case OPSLASH:
  3033.         switch(type)
  3034.         {
  3035.         case TYINT1:
  3036.         case TYSHORT:
  3037.         case TYLONG:
  3038. #ifdef TYQUAD
  3039.         case TYQUAD:
  3040. #endif
  3041.             cp->ci = ap->ci / bp->ci;
  3042.             break;
  3043.         case TYREAL:
  3044.         case TYDREAL:
  3045.             cp->cd[0] = ad[0] / bd[0];
  3046.             break;
  3047.         case TYCOMPLEX:
  3048.         case TYDCOMPLEX:
  3049.             zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
  3050.             break;
  3051.         }
  3052.         break;
  3053.  
  3054.     case OPMOD:
  3055.         if( ISINT(type) )
  3056.         {
  3057.             cp->ci = ap->ci % bp->ci;
  3058.             break;
  3059.         }
  3060.         else
  3061.             Fatal("inline mod of noninteger");
  3062.  
  3063.     case OPMIN2:
  3064.     case OPDMIN:
  3065.         switch(type)
  3066.         {
  3067.         case TYINT1:
  3068.         case TYSHORT:
  3069.         case TYLONG:
  3070. #ifdef TYQUAD
  3071.         case TYQUAD:
  3072. #endif
  3073.             cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
  3074.             break;
  3075.         case TYREAL:
  3076.         case TYDREAL:
  3077.             cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
  3078.             break;
  3079.         default:
  3080.             Fatal("inline min of exected type");
  3081.         }
  3082.         break;
  3083.  
  3084.     case OPMAX2:
  3085.     case OPDMAX:
  3086.         switch(type)
  3087.         {
  3088.         case TYINT1:
  3089.         case TYSHORT:
  3090.         case TYLONG:
  3091. #ifdef TYQUAD
  3092.         case TYQUAD:
  3093. #endif
  3094.             cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
  3095.             break;
  3096.         case TYREAL:
  3097.         case TYDREAL:
  3098.             cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
  3099.             break;
  3100.         default:
  3101.             Fatal("inline max of exected type");
  3102.         }
  3103.         break;
  3104.  
  3105.     default:      /* relational ops */
  3106.         switch(type)
  3107.         {
  3108.         case TYINT1:
  3109.         case TYSHORT:
  3110.         case TYLONG:
  3111. #ifdef TYQUAD
  3112.         case TYQUAD:
  3113. #endif
  3114.             if(ap->ci < bp->ci)
  3115.                 k = -1;
  3116.             else if(ap->ci == bp->ci)
  3117.                 k = 0;
  3118.             else    k = 1;
  3119.             break;
  3120.         case TYREAL:
  3121.         case TYDREAL:
  3122.             if(ad[0] < bd[0])
  3123.                 k = -1;
  3124.             else if(ad[0] == bd[0])
  3125.                 k = 0;
  3126.             else    k = 1;
  3127.             break;
  3128.         case TYCOMPLEX:
  3129.         case TYDCOMPLEX:
  3130.             if(ad[0] == bd[0] &&
  3131.                 ad[1] == bd[1] )
  3132.                 k = 0;
  3133.             else    k = 1;
  3134.             break;
  3135.         }
  3136.  
  3137.         switch(opcode)
  3138.         {
  3139.         case OPEQ:
  3140.             cp->ci = (k == 0);
  3141.             break;
  3142.         case OPNE:
  3143.             cp->ci = (k != 0);
  3144.             break;
  3145.         case OPGT:
  3146.             cp->ci = (k == 1);
  3147.             break;
  3148.         case OPLT:
  3149.             cp->ci = (k == -1);
  3150.             break;
  3151.         case OPGE:
  3152.             cp->ci = (k >= 0);
  3153.             break;
  3154.         case OPLE:
  3155.             cp->ci = (k <= 0);
  3156.             break;
  3157.         }
  3158.         break;
  3159.     }
  3160. }
  3161.  
  3162.  
  3163.  
  3164. /* conssgn - returns the sign of a Fortran constant */
  3165.  
  3166. #ifdef KR_headers
  3167. conssgn(p)
  3168.     register expptr p;
  3169. #else
  3170. conssgn(register expptr p)
  3171. #endif
  3172. {
  3173.     register char *s;
  3174.  
  3175.     if( ! ISCONST(p) )
  3176.         Fatal( "sgn(nonconstant)" );
  3177.  
  3178.     switch(p->headblock.vtype)
  3179.     {
  3180.     case TYINT1:
  3181.     case TYSHORT:
  3182.     case TYLONG:
  3183. #ifdef TYQUAD
  3184.     case TYQUAD:
  3185. #endif
  3186.         if(p->constblock.Const.ci > 0) return(1);
  3187.         if(p->constblock.Const.ci < 0) return(-1);
  3188.         return(0);
  3189.  
  3190.     case TYREAL:
  3191.     case TYDREAL:
  3192.         if (p->constblock.vstg) {
  3193.             s = p->constblock.Const.cds[0];
  3194.             if (*s == '-')
  3195.                 return -1;
  3196.             if (*s == '0')
  3197.                 return 0;
  3198.             return 1;
  3199.             }
  3200.         if(p->constblock.Const.cd[0] > 0) return(1);
  3201.         if(p->constblock.Const.cd[0] < 0) return(-1);
  3202.         return(0);
  3203.  
  3204.  
  3205. /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
  3206.  
  3207.     case TYCOMPLEX:
  3208.     case TYDCOMPLEX:
  3209.         if (p->constblock.vstg)
  3210.             return *p->constblock.Const.cds[0] != '0'
  3211.                 && *p->constblock.Const.cds[1] != '0';
  3212.         return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
  3213.  
  3214.     default:
  3215.         badtype( "conssgn", p->constblock.vtype);
  3216.     }
  3217.     /* NOT REACHED */ return 0;
  3218. }
  3219.  
  3220. char *powint[ ] = {
  3221.     "pow_ii",
  3222. #ifdef TYQUAD
  3223.           "pow_qq",
  3224. #endif
  3225.           "pow_ri", "pow_di", "pow_ci", "pow_zi" };
  3226.  
  3227.  LOCAL expptr
  3228. #ifdef KR_headers
  3229. mkpower(p)
  3230.     register expptr p;
  3231. #else
  3232. mkpower(register expptr p)
  3233. #endif
  3234. {
  3235.     register expptr q, lp, rp;
  3236.     int ltype, rtype, mtype, tyi;
  3237.  
  3238.     lp = p->exprblock.leftp;
  3239.     rp = p->exprblock.rightp;
  3240.     ltype = lp->headblock.vtype;
  3241.     rtype = rp->headblock.vtype;
  3242.  
  3243.     if (lp->tag == TADDR)
  3244.         lp->addrblock.parenused = 0;
  3245.  
  3246.     if (rp->tag == TADDR)
  3247.         rp->addrblock.parenused = 0;
  3248.  
  3249.     if(ISICON(rp))
  3250.     {
  3251.         if(rp->constblock.Const.ci == 0)
  3252.         {
  3253.             frexpr(p);
  3254.             if( ISINT(ltype) )
  3255.                 return( ICON(1) );
  3256.             else if (ISREAL (ltype))
  3257.                 return mkconv (ltype, ICON (1));
  3258.             else
  3259.                 return( (expptr) putconst((Constp)
  3260.                     mkconv(ltype, ICON(1))) );
  3261.         }
  3262.         if(rp->constblock.Const.ci < 0)
  3263.         {
  3264.             if( ISINT(ltype) )
  3265.             {
  3266.                 frexpr(p);
  3267.                 err("integer**negative");
  3268.                 return( errnode() );
  3269.             }
  3270.             rp->constblock.Const.ci = - rp->constblock.Const.ci;
  3271.             p->exprblock.leftp = lp
  3272.                 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
  3273.         }
  3274.         if(rp->constblock.Const.ci == 1)
  3275.         {
  3276.             frexpr(rp);
  3277.             free( (charptr) p );
  3278.             return(lp);
  3279.         }
  3280.  
  3281.         if( ONEOF(ltype, MSKINT|MSKREAL) ) {
  3282.             p->exprblock.vtype = ltype;
  3283.             return(p);
  3284.         }
  3285.     }
  3286.     if( ISINT(rtype) )
  3287.     {
  3288.         if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
  3289.             q = call2(TYSHORT, "pow_hh", lp, rp);
  3290.         else    {
  3291.             if(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
  3292.             {
  3293.                 ltype = TYLONG;
  3294.                 lp = mkconv(TYLONG,lp);
  3295.             }
  3296. #ifdef TYQUAD
  3297.             if (ltype == TYQUAD)
  3298.                 rp = mkconv(TYQUAD,rp);
  3299.             else
  3300. #endif
  3301.             rp = mkconv(TYLONG,rp);
  3302.             if (ISCONST(rp)) {
  3303.                 tyi = tyint;
  3304.                 tyint = TYLONG;
  3305.                 rp = (expptr)putconst((Constp)rp);
  3306.                 tyint = tyi;
  3307.                 }
  3308.             q = call2(ltype, powint[ltype-TYLONG], lp, rp);
  3309.         }
  3310.     }
  3311.     else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
  3312.         extern int callk_kludge;
  3313.         callk_kludge = TYDREAL;
  3314.         q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
  3315.         callk_kludge = 0;
  3316.         }
  3317.     else    {
  3318.         q  = call2(TYDCOMPLEX, "pow_zz",
  3319.             mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
  3320.         if(mtype == TYCOMPLEX)
  3321.             q = mkconv(TYCOMPLEX, q);
  3322.     }
  3323.     free( (charptr) p );
  3324.     return(q);
  3325. }
  3326.  
  3327.  
  3328. /* Complex Division.  Same code as in Runtime Library
  3329. */
  3330.  
  3331.  
  3332.  LOCAL void
  3333. #ifdef KR_headers
  3334. zdiv(c, a, b)
  3335.     register dcomplex *c;
  3336.     register dcomplex *a;
  3337.     register dcomplex *b;
  3338. #else
  3339. zdiv(register dcomplex *c, register dcomplex *a, register dcomplex *b)
  3340. #endif
  3341. {
  3342.     double ratio, den;
  3343.     double abr, abi;
  3344.  
  3345.     if( (abr = b->dreal) < 0.)
  3346.         abr = - abr;
  3347.     if( (abi = b->dimag) < 0.)
  3348.         abi = - abi;
  3349.     if( abr <= abi )
  3350.     {
  3351.         if(abi == 0)
  3352.             Fatal("complex division by zero");
  3353.         ratio = b->dreal / b->dimag ;
  3354.         den = b->dimag * (1 + ratio*ratio);
  3355.         c->dreal = (a->dreal*ratio + a->dimag) / den;
  3356.         c->dimag = (a->dimag*ratio - a->dreal) / den;
  3357.     }
  3358.  
  3359.     else
  3360.     {
  3361.         ratio = b->dimag / b->dreal ;
  3362.         den = b->dreal * (1 + ratio*ratio);
  3363.         c->dreal = (a->dreal + a->dimag*ratio) / den;
  3364.         c->dimag = (a->dimag - a->dreal*ratio) / den;
  3365.     }
  3366. }
  3367.